{-# 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
import Language.Haskell.TH.Syntax hiding (lift)
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 :: a -> [a]
universe = a -> [a]
forall s t. UniverseBi s t => s -> [t]
universeBi
transform :: (TransformBi a a) => (a -> a) -> a -> a
transform :: (a -> a) -> a -> a
transform = (a -> a) -> a -> a
forall s t. TransformBi s t => (s -> s) -> t -> t
transformBi
transformM :: (TransformBiM m a a) => (a -> m a) -> a -> m a
transformM :: (a -> m a) -> a -> m a
transformM = (a -> m a) -> a -> m a
forall (m :: * -> *) s t.
TransformBiM m s t =>
(s -> m s) -> t -> m t
transformBiM
descend :: (DescendM Identity a) => (a -> a) -> (a -> a)
descend :: (a -> a) -> a -> a
descend f :: a -> a
f = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> (a -> Identity a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity a) -> a -> Identity a
forall (m :: * -> *) t. DescendM m t => (t -> m t) -> t -> m t
descendM (a -> Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Identity a) -> (a -> a) -> a -> Identity a
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 stops :: [TypeQ]
stops ty :: TypeQ
ty = [TypeQ] -> Type -> Q [Dec]
instanceUniverseBiT' [TypeQ]
stops (Type -> Q [Dec]) -> TypeQ -> Q [Dec]
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' stops :: [TypeQ]
stops (ForallT _ _ t :: Type
t) = [TypeQ] -> Type -> Q [Dec]
instanceUniverseBiT' [TypeQ]
stops Type
t
instanceUniverseBiT' stops :: [TypeQ]
stops ty :: Type
ty | (TupleT _, [from :: Type
from, to :: Type
to]) <- Type -> (Type, [Type])
splitTypeApp Type
ty = do
(ds :: [Dec]
ds, f :: Exp
f) <- [TypeQ] -> Type -> Type -> Q ([Dec], Exp)
uniBiQ [TypeQ]
stops Type
from Type
to
Name
x <- String -> Q Name
newName "_x"
let e :: Exp
e = [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
x] (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Dec] -> Exp -> Exp
LetE [Dec]
ds (Exp -> Exp) -> Exp -> Exp
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 [])
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Name -> Exp -> [Dec]
instDef ''UniverseBi [Type
from, Type
to] 'universeBi Exp
e
instanceUniverseBiT' _ t :: Type
t = String -> Q [Dec]
forall a. String -> a
genError "instanceUniverseBi: the argument should be of the form [t| (S, T) |]"
funDef :: Name -> Exp -> [Dec]
funDef :: Name -> Exp -> [Dec]
funDef f :: Name
f e :: 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 __GLASGOW_HASKELL__ <= 710
instDef cls ts met e = [InstanceD [] (foldl AppT (ConT cls) ts) (funDef met e)]
#else
instDef :: Name -> [Type] -> Name -> Exp -> [Dec]
instDef cls :: Name
cls ts :: [Type]
ts met :: Name
met e :: Exp
e = [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] ((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
cls) [Type]
ts) (Name -> Exp -> [Dec]
funDef Name
met Exp
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 stops :: [TypeQ]
stops ty :: TypeQ
ty = Mode -> [TypeQ] -> Type -> Q [Dec]
instanceTransformBiT' Mode
MTransformBi [TypeQ]
stops (Type -> Q [Dec]) -> TypeQ -> Q [Dec]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
ty
data Mode = MTransformBi | MDescendBi | MDescend
deriving (Mode -> Mode -> Bool
(Mode -> Mode -> Bool) -> (Mode -> Mode -> Bool) -> Eq Mode
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
Eq Mode =>
(Mode -> Mode -> Ordering)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Mode)
-> (Mode -> Mode -> Mode)
-> Ord 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
$cp1Ord :: Eq Mode
Ord, Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
(Int -> Mode -> ShowS)
-> (Mode -> String) -> ([Mode] -> ShowS) -> Show Mode
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' doDescend :: Mode
doDescend stops :: [TypeQ]
stops (ForallT _ _ t :: Type
t) = Mode -> [TypeQ] -> Type -> Q [Dec]
instanceTransformBiT' Mode
doDescend [TypeQ]
stops Type
t
instanceTransformBiT' doDescend :: Mode
doDescend stops :: [TypeQ]
stops ty :: Type
ty | (TupleT _, [ft :: Type
ft, st :: Type
st]) <- Type -> (Type, [Type])
splitTypeApp Type
ty = do
Name
f <- String -> Q Name
newName "_f"
Name
x <- String -> Q Name
newName "_x"
(ds :: [Dec]
ds, tr :: 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] (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Dec] -> Exp -> Exp
LetE [Dec]
ds (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
tr (Name -> Exp
VarE Name
x)
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Name -> Exp -> [Dec]
instDef ''TransformBi [Type
ft, Type
st] 'transformBi Exp
e
instanceTransformBiT' _ _ t :: Type
t = String -> Q [Dec]
forall a. String -> a
genError "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 stops :: [TypeQ]
stops mndq :: TypeQ
mndq ty :: TypeQ
ty = Mode -> [TypeQ] -> TypeQ -> Type -> Q [Dec]
instanceTransformBiMT' Mode
MDescend [TypeQ]
stops TypeQ
mndq (Type -> Q [Dec]) -> TypeQ -> Q [Dec]
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 stops :: [TypeQ]
stops mndq :: TypeQ
mndq ty :: TypeQ
ty = Mode -> [TypeQ] -> TypeQ -> Type -> Q [Dec]
instanceTransformBiMT' Mode
MDescendBi [TypeQ]
stops TypeQ
mndq (Type -> Q [Dec]) -> TypeQ -> Q [Dec]
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 stops :: [TypeQ]
stops mndq :: TypeQ
mndq ty :: TypeQ
ty = Mode -> [TypeQ] -> TypeQ -> Type -> Q [Dec]
instanceTransformBiMT' Mode
MTransformBi [TypeQ]
stops TypeQ
mndq (Type -> Q [Dec]) -> TypeQ -> Q [Dec]
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' doDescend :: Mode
doDescend stops :: [TypeQ]
stops mndq :: TypeQ
mndq (ForallT _ _ t :: Type
t) = Mode -> [TypeQ] -> TypeQ -> Type -> Q [Dec]
instanceTransformBiMT' Mode
doDescend [TypeQ]
stops TypeQ
mndq Type
t
instanceTransformBiMT' MDescend stops :: [TypeQ]
stops mndq :: TypeQ
mndq ty :: Type
ty = do
Type
mnd <- TypeQ
mndq
Name
f <- String -> Q Name
newName "_f"
Name
x <- String -> Q Name
newName "_x"
(ds :: [Dec]
ds, tr :: 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] (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Dec] -> Exp -> Exp
LetE [Dec]
ds (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
tr (Name -> Exp
VarE Name
x)
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Name -> Exp -> [Dec]
instDef ''DescendM [Type
mnd, Type
ty] 'descendM Exp
e
instanceTransformBiMT' doDescend :: Mode
doDescend stops :: [TypeQ]
stops mndq :: TypeQ
mndq ty :: Type
ty | (TupleT _, [ft :: Type
ft, st :: Type
st]) <- Type -> (Type, [Type])
splitTypeApp Type
ty = do
Type
mnd <- TypeQ
mndq
Name
f <- String -> Q Name
newName "_f"
Name
x <- String -> Q Name
newName "_x"
(ds :: [Dec]
ds, tr :: 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] (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Dec] -> Exp -> Exp
LetE [Dec]
ds (Exp -> Exp) -> Exp -> Exp
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 MTransformBi -> ''TransformBiM; MDescendBi -> ''DescendBiM; MDescend -> String -> Name
forall a. HasCallStack => String -> a
error "MDescend"
met :: Name
met = case Mode
doDescend of MTransformBi -> 'transformBiM; MDescendBi -> 'descendBiM; MDescend -> String -> Name
forall a. HasCallStack => String -> a
error "MDescend"
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
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' _ _ _ t :: Type
t = String -> Q [Dec]
forall a. String -> a
genError "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 stops :: [TypeQ]
stops = Name -> Q ([TyVarBndr], Type, Type)
forall (q :: * -> *).
Quasi q =>
Name -> q ([TyVarBndr], Type, Type)
getNameType (Name -> Q ([TyVarBndr], Type, Type))
-> (([TyVarBndr], Type, Type) -> Q Exp) -> Name -> Q Exp
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [TypeQ] -> ([TyVarBndr], Type, Type) -> Q Exp
genUniverseBiTsplit [TypeQ]
stops
genUniverseBiT' :: [TypeQ] -> TypeQ -> Q Exp
genUniverseBiT' :: [TypeQ] -> TypeQ -> Q Exp
genUniverseBiT' stops :: [TypeQ]
stops q :: TypeQ
q = TypeQ
q TypeQ
-> (Type -> Q ([TyVarBndr], Type, Type))
-> Q ([TyVarBndr], Type, Type)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Q ([TyVarBndr], Type, Type)
forall (q :: * -> *).
Quasi q =>
Type -> q ([TyVarBndr], Type, Type)
splitType Q ([TyVarBndr], Type, Type)
-> (([TyVarBndr], Type, Type) -> Q Exp) -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [TypeQ] -> ([TyVarBndr], Type, Type) -> Q Exp
genUniverseBiTsplit [TypeQ]
stops
genUniverseBiTsplit :: [TypeQ] -> ([TyVarBndr], Type, Type) -> Q Exp
genUniverseBiTsplit :: [TypeQ] -> ([TyVarBndr], Type, Type) -> Q Exp
genUniverseBiTsplit stops :: [TypeQ]
stops (_tvs :: [TyVarBndr]
_tvs,from :: Type
from,tos :: Type
tos) = do
let to :: Type
to = Type -> Type
unList Type
tos
(ds :: [Dec]
ds, f :: Exp
f) <- [TypeQ] -> Type -> Type -> Q ([Dec], Exp)
uniBiQ [TypeQ]
stops Type
from Type
to
Name
x <- String -> Q Name
newName "_x"
let e :: Exp
e = [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
x] (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Dec] -> Exp -> Exp
LetE [Dec]
ds (Exp -> Exp) -> Exp -> Exp
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 [])
Exp -> Q Exp
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 = Q Name -> U Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name -> U Name) -> (String -> Q Name) -> String -> U Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName
qReport :: Bool -> String -> U ()
qReport b :: Bool
b = Q () -> U ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q () -> U ()) -> (String -> Q ()) -> String -> U ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
b
qRecover :: U a -> U a -> U a
qRecover = String -> U a -> U a -> U a
forall a. HasCallStack => String -> a
error "Data.Generics.Geniplate: qRecover not implemented"
qReify :: Name -> U Info
qReify = Q Info -> U Info
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Info -> U Info) -> (Name -> Q Info) -> Name -> U Info
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Info
forall (m :: * -> *). Quasi m => Name -> m Info
qReify
#if __GLASGOW_HASKELL__ >= 704
qReifyInstances :: Name -> [Type] -> U [Dec]
qReifyInstances n :: Name
n = Q [Dec] -> U [Dec]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [Dec] -> U [Dec]) -> ([Type] -> Q [Dec]) -> [Type] -> U [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Type] -> Q [Dec]
forall (m :: * -> *). Quasi m => Name -> [Type] -> m [Dec]
qReifyInstances Name
n
#elif __GLASGOW_HASKELL__ >= 702
qClassInstances n = lift . qClassInstances n
#endif
qLocation :: U Loc
qLocation = Q Loc -> U Loc
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Loc
forall (m :: * -> *). Quasi m => m Loc
qLocation
qRunIO :: IO a -> U a
qRunIO = Q a -> U a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q a -> U a) -> (IO a -> Q a) -> IO a -> U a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> Q a
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO
#if __GLASGOW_HASKELL__ >= 706
qLookupName :: Bool -> String -> U (Maybe Name)
qLookupName ns :: Bool
ns = Q (Maybe Name) -> U (Maybe Name)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q (Maybe Name) -> U (Maybe Name))
-> (String -> Q (Maybe Name)) -> String -> U (Maybe Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String -> Q (Maybe Name)
forall (m :: * -> *). Quasi m => Bool -> String -> m (Maybe Name)
qLookupName Bool
ns
qAddDependentFile :: String -> U ()
qAddDependentFile = Q () -> U ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q () -> U ()) -> (String -> Q ()) -> String -> U ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q ()
forall (m :: * -> *). Quasi m => String -> m ()
qAddDependentFile
#if __GLASGOW_HASKELL__ >= 708
qReifyRoles :: Name -> U [Role]
qReifyRoles = Q [Role] -> U [Role]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [Role] -> U [Role]) -> (Name -> Q [Role]) -> Name -> U [Role]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q [Role]
forall (m :: * -> *). Quasi m => Name -> m [Role]
qReifyRoles
qReifyAnnotations :: AnnLookup -> U [a]
qReifyAnnotations = Q [a] -> U [a]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [a] -> U [a]) -> (AnnLookup -> Q [a]) -> AnnLookup -> U [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnLookup -> Q [a]
forall (m :: * -> *) a. (Quasi m, Data a) => AnnLookup -> m [a]
qReifyAnnotations
qReifyModule :: Module -> U ModuleInfo
qReifyModule = Q ModuleInfo -> U ModuleInfo
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q ModuleInfo -> U ModuleInfo)
-> (Module -> Q ModuleInfo) -> Module -> U ModuleInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> Q ModuleInfo
forall (m :: * -> *). Quasi m => Module -> m ModuleInfo
qReifyModule
qAddTopDecls :: [Dec] -> U ()
qAddTopDecls = Q () -> U ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q () -> U ()) -> ([Dec] -> Q ()) -> [Dec] -> U ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Dec] -> Q ()
forall (m :: * -> *). Quasi m => [Dec] -> m ()
qAddTopDecls
qAddModFinalizer :: Q () -> U ()
qAddModFinalizer = Q () -> U ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q () -> U ()) -> (Q () -> Q ()) -> Q () -> U ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q () -> Q ()
forall (m :: * -> *). Quasi m => Q () -> m ()
qAddModFinalizer
qGetQ :: U (Maybe a)
qGetQ = U (Maybe a)
forall a. HasCallStack => a
undefined
qPutQ :: a -> U ()
qPutQ = Q () -> U ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q () -> U ()) -> (a -> Q ()) -> a -> U ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Q ()
forall (m :: * -> *) a. (Quasi m, Typeable a) => a -> m ()
qPutQ
#endif
#endif
uniBiQ :: [TypeQ] -> Type -> Type -> Q ([Dec], Exp)
uniBiQ :: [TypeQ] -> Type -> Type -> Q ([Dec], Exp)
uniBiQ stops :: [TypeQ]
stops from :: Type
from ato :: Type
ato = do
[Type]
ss <- [TypeQ] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [TypeQ]
stops
Type
to <- Type -> TypeQ
forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
ato
(f :: Exp
f, (m :: Map Type Dec
m, _)) <- StateT (Map Type Dec, Map Type Bool) Q Exp
-> (Map Type Dec, Map Type Bool)
-> Q (Exp, (Map Type Dec, Map Type Bool))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Type -> Type -> StateT (Map Type Dec, Map Type Bool) Q Exp
uniBi Type
from Type
to) (Map Type Dec
forall a b. Map a b
mEmpty, [(Type, Bool)] -> Map Type Bool
forall a b. [(a, b)] -> Map a b
mFromList ([(Type, Bool)] -> Map Type Bool)
-> [(Type, Bool)] -> Map Type Bool
forall a b. (a -> b) -> a -> b
$ [Type] -> [Bool] -> [(Type, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
ss (Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False))
([Dec], Exp) -> Q ([Dec], Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Type Dec -> [Dec]
forall a b. Map a b -> [b]
mElems Map Type Dec
m, Exp
f)
uniBi :: Type -> Type -> U Exp
uniBi :: Type -> Type -> StateT (Map Type Dec, Map Type Bool) Q Exp
uniBi afrom :: Type
afrom to :: Type
to = do
(m :: Map Type Dec
m, c :: Map Type Bool
c) <- StateT
(Map Type Dec, Map Type Bool) Q (Map Type Dec, Map Type Bool)
forall s (m :: * -> *). MonadState s m => m s
get
Type
from <- Type -> StateT (Map Type Dec, Map Type Bool) Q Type
forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
afrom
case Type -> Map Type Dec -> Maybe Dec
forall a b. Eq a => a -> Map a b -> Maybe b
mLookup Type
from Map Type Dec
m of
Just (FunD n :: Name
n _) -> Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp)
-> Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
n
_ -> do
Name
f <- String -> U Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName "_f"
let mkRec :: StateT (Map Type Dec, Map Type Bool) Q [Clause]
mkRec = do
(Map Type Dec, Map Type Bool) -> U ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Type -> Dec -> Map Type Dec -> Map Type Dec
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 (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ [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 Type -> Type -> Bool
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 <- String -> U Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName "_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
((Map Type Dec, Map Type Bool) -> (Map Type Dec, Map Type Bool))
-> U ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Map Type Dec, Map Type Bool) -> (Map Type Dec, Map Type Bool))
-> U ())
-> ((Map Type Dec, Map Type Bool) -> (Map Type Dec, Map Type Bool))
-> U ()
forall a b. (a -> b) -> a -> b
$ \ (m' :: Map Type Dec
m', c' :: Map Type Bool
c') -> (Type -> Dec -> Map Type Dec -> Map Type Dec
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
((Map Type Dec, Map Type Bool) -> (Map Type Dec, Map Type Bool))
-> U ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Map Type Dec, Map Type Bool) -> (Map Type Dec, Map Type Bool))
-> U ())
-> ((Map Type Dec, Map Type Bool) -> (Map Type Dec, Map Type Bool))
-> U ()
forall a b. (a -> b) -> a -> b
$ \ (m' :: Map Type Dec
m', c' :: Map Type Bool
c') -> (Type -> Dec -> Map Type Dec -> Map Type Dec
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')
Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp)
-> Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
f
contains :: Type -> Type -> U Bool
contains :: Type -> Type -> U Bool
contains to :: Type
to afrom :: Type
afrom = do
Type
from <- Type -> StateT (Map Type Dec, Map Type Bool) Q Type
forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
afrom
if Type
from Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
to then
Bool -> U Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
Map Type Bool
c <- ((Map Type Dec, Map Type Bool) -> Map Type Bool)
-> StateT (Map Type Dec, Map Type Bool) Q (Map Type Bool)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Map Type Dec, Map Type Bool) -> Map Type Bool
forall a b. (a, b) -> b
snd
case Type -> Map Type Bool -> Maybe Bool
forall a. Type -> Map Type a -> Maybe a
mLookupSplits Type
from Map Type Bool
c of
Just b :: Bool
b -> Bool -> U Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
Nothing -> Type -> Type -> U Bool
contains' Type
to Type
from
mLookupSplits :: Type -> Map Type a -> Maybe a
mLookupSplits :: Type -> Map Type a -> Maybe a
mLookupSplits ty :: Type
ty m :: Map Type a
m = [Maybe a] -> Maybe a
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [ Type -> Map Type a -> Maybe a
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 u :: Type
u _) = Type
tType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:Type -> [Type]
splits Type
u
splits t :: Type
t = [Type
t]
contains' :: Type -> Type -> U Bool
contains' :: Type -> Type -> U Bool
contains' to :: Type
to from :: Type
from = do
let (con :: Type
con, ts :: [Type]
ts) = Type -> (Type, [Type])
splitTypeApp Type
from
((Map Type Dec, Map Type Bool) -> (Map Type Dec, Map Type Bool))
-> U ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Map Type Dec, Map Type Bool) -> (Map Type Dec, Map Type Bool))
-> U ())
-> ((Map Type Dec, Map Type Bool) -> (Map Type Dec, Map Type Bool))
-> U ()
forall a b. (a -> b) -> a -> b
$ \ (m :: Map Type Dec
m, c :: Map Type Bool
c) -> (Map Type Dec
m, Type -> Bool -> Map Type Bool -> Map Type Bool
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 n :: Name
n -> Name -> Type -> [Type] -> U Bool
containsCon Name
n Type
to [Type]
ts
TupleT _ -> ([Bool] -> Bool)
-> StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool)
-> StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool
forall a b. (a -> b) -> a -> b
$ (Type -> U Bool)
-> [Type] -> StateT (Map Type Dec, Map Type Bool) Q [Bool]
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
ArrowT -> Bool -> U Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
ListT -> if Type
to Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
from then Bool -> U Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else Type -> Type -> U Bool
contains Type
to ([Type] -> Type
forall a. [a] -> a
head [Type]
ts)
VarT _ -> Bool -> U Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
t :: Type
t -> String -> U Bool
forall a. String -> a
genError (String -> U Bool) -> String -> U Bool
forall a b. (a -> b) -> a -> b
$ "contains: unexpected type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
from String -> ShowS
forall a. [a] -> [a] -> [a]
++ " (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"
((Map Type Dec, Map Type Bool) -> (Map Type Dec, Map Type Bool))
-> U ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Map Type Dec, Map Type Bool) -> (Map Type Dec, Map Type Bool))
-> U ())
-> ((Map Type Dec, Map Type Bool) -> (Map Type Dec, Map Type Bool))
-> U ()
forall a b. (a -> b) -> a -> b
$ \ (m :: Map Type Dec
m, c :: Map Type Bool
c) -> (Map Type Dec
m, Type -> Bool -> Map Type Bool -> Map Type Bool
forall a b. Eq a => a -> b -> Map a b -> Map a b
mInsert Type
from Bool
b Map Type Bool
c)
Bool -> U Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
containsCon :: Name -> Type -> [Type] -> U Bool
containsCon :: Name -> Type -> [Type] -> U Bool
containsCon con :: Name
con to :: Type
to ts :: [Type]
ts = do
(tvs :: [TyVarBndr]
tvs, cons :: [Con]
cons) <- Name -> StateT (Map Type Dec, Map Type Bool) Q ([TyVarBndr], [Con])
forall (q :: * -> *). Quasi q => Name -> q ([TyVarBndr], [Con])
getTyConInfo Name
con
let conCon :: Con -> U Bool
conCon (NormalC _ xs :: [BangType]
xs) = ([Bool] -> Bool)
-> StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool)
-> StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool
forall a b. (a -> b) -> a -> b
$ (BangType -> U Bool)
-> [BangType] -> StateT (Map Type Dec, Map Type Bool) Q [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> U Bool
field (Type -> U Bool) -> (BangType -> Type) -> BangType -> U Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BangType -> Type
forall a b. (a, b) -> b
snd) [BangType]
xs
conCon (InfixC x1 :: BangType
x1 _ x2 :: BangType
x2) = ([Bool] -> Bool)
-> StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool)
-> StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool
forall a b. (a -> b) -> a -> b
$ (Type -> U Bool)
-> [Type] -> StateT (Map Type Dec, Map Type Bool) Q [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> U Bool
field [BangType -> Type
forall a b. (a, b) -> b
snd BangType
x1, BangType -> Type
forall a b. (a, b) -> b
snd BangType
x2]
conCon (RecC _ xs :: [VarBangType]
xs) = ([Bool] -> Bool)
-> StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool)
-> StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool
forall a b. (a -> b) -> a -> b
$ (Type -> U Bool)
-> [Type] -> StateT (Map Type Dec, Map Type Bool) Q [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> U Bool
field [ Type
t | (_,_,t :: Type
t) <- [VarBangType]
xs ]
conCon c :: Con
c = String -> U Bool
forall a. String -> a
genError (String -> U Bool) -> String -> U Bool
forall a b. (a -> b) -> a -> b
$ "containsCon: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Con -> String
forall a. Show a => a -> String
show Con
c
s :: Subst
s = [TyVarBndr] -> [Type] -> Subst
mkSubst [TyVarBndr]
tvs [Type]
ts
field :: Type -> U Bool
field t :: Type
t = Type -> Type -> U Bool
contains Type
to (Subst -> Type -> Type
subst Subst
s Type
t)
([Bool] -> Bool)
-> StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool)
-> StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool
forall a b. (a -> b) -> a -> b
$ (Con -> U Bool)
-> [Con] -> StateT (Map Type Dec, Map Type Bool) Q [Bool]
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 _ cs :: [Clause]
cs] = [Clause]
cs
unFunD _ = String -> [Clause]
forall a. String -> a
genError (String -> [Clause]) -> String -> [Clause]
forall a b. (a -> b) -> a -> b
$ "unFunD"
unFun :: Q [Dec] -> U [Clause]
unFun :: Q [Dec] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
unFun = Q [Clause] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [Clause] -> StateT (Map Type Dec, Map Type Bool) Q [Clause])
-> (Q [Dec] -> Q [Clause])
-> Q [Dec]
-> StateT (Map Type Dec, Map Type Bool) Q [Clause]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Dec] -> [Clause]) -> Q [Dec] -> Q [Clause]
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 from :: Type
from to :: Type
to = do
let (con :: Type
con, ts :: [Type]
ts) = Type -> (Type, [Type])
splitTypeApp Type
from
case Type
con of
ConT n :: Name
n -> Name
-> [Type]
-> Type
-> StateT (Map Type Dec, Map Type Bool) Q [Clause]
uniBiCon Name
n [Type]
ts Type
to
TupleT _ -> [Type] -> Type -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
uniBiTuple [Type]
ts Type
to
ListT -> Type -> Type -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
uniBiList ([Type] -> Type
forall a. [a] -> a
head [Type]
ts) Type
to
t :: Type
t -> String -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
forall a. String -> a
genError (String -> StateT (Map Type Dec, Map Type Bool) Q [Clause])
-> String -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
forall a b. (a -> b) -> a -> b
$ "uniBiCase: unexpected type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
from String -> ShowS
forall a. [a] -> [a] -> [a]
++ " (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"
uniBiList :: Type -> Type -> U [Clause]
uniBiList :: Type -> Type -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
uniBiList t :: Type
t to :: Type
to = do
Exp
uni <- Type -> Type -> StateT (Map Type Dec, Map Type Bool) Q Exp
uniBi Type
t Type
to
Exp
rec <- Type -> Type -> StateT (Map Type Dec, Map Type Bool) Q 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 ts :: [Type]
ts to :: Type
to = (Clause -> [Clause])
-> StateT (Map Type Dec, Map Type Bool) Q Clause
-> StateT (Map Type Dec, Map Type Bool) Q [Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Clause -> [Clause] -> [Clause]
forall a. a -> [a] -> [a]
:[]) (StateT (Map Type Dec, Map Type Bool) Q Clause
-> StateT (Map Type Dec, Map Type Bool) Q [Clause])
-> StateT (Map Type Dec, Map Type Bool) Q Clause
-> StateT (Map Type Dec, Map Type Bool) Q [Clause]
forall a b. (a -> b) -> a -> b
$ Type
-> Subst
-> ([Pat] -> Pat)
-> [Type]
-> StateT (Map Type Dec, Map Type Bool) Q 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 con :: Name
con ts :: [Type]
ts to :: Type
to = do
(tvs :: [TyVarBndr]
tvs, cons :: [Con]
cons) <- Name -> StateT (Map Type Dec, Map Type Bool) Q ([TyVarBndr], [Con])
forall (q :: * -> *). Quasi q => Name -> q ([TyVarBndr], [Con])
getTyConInfo Name
con
let genArm :: Con -> StateT (Map Type Dec, Map Type Bool) Q Clause
genArm (NormalC c :: Name
c xs :: [BangType]
xs) = ([Pat] -> Pat)
-> [BangType] -> StateT (Map Type Dec, Map Type Bool) Q Clause
forall a.
([Pat] -> Pat)
-> [(a, Type)] -> StateT (Map Type Dec, Map Type Bool) Q Clause
arm (Name -> [Pat] -> Pat
ConP Name
c) [BangType]
xs
genArm (InfixC x1 :: BangType
x1 c :: Name
c x2 :: BangType
x2) = ([Pat] -> Pat)
-> [BangType] -> StateT (Map Type Dec, Map Type Bool) Q Clause
forall a.
([Pat] -> Pat)
-> [(a, Type)] -> StateT (Map Type Dec, Map Type Bool) Q Clause
arm (\ [p1 :: Pat
p1, p2 :: Pat
p2] -> Pat -> Name -> Pat -> Pat
InfixP Pat
p1 Name
c Pat
p2) [BangType
x1, BangType
x2]
genArm (RecC c :: Name
c xs :: [VarBangType]
xs) = ([Pat] -> Pat)
-> [BangType] -> StateT (Map Type Dec, Map Type Bool) Q Clause
forall a.
([Pat] -> Pat)
-> [(a, Type)] -> StateT (Map Type Dec, Map Type Bool) Q Clause
arm (Name -> [Pat] -> Pat
ConP Name
c) [ (Bang
b,Type
t) | (_,b :: Bang
b,t :: Type
t) <- [VarBangType]
xs ]
genArm c :: Con
c = String -> StateT (Map Type Dec, Map Type Bool) Q Clause
forall a. String -> a
genError (String -> StateT (Map Type Dec, Map Type Bool) Q Clause)
-> String -> StateT (Map Type Dec, Map Type Bool) Q Clause
forall a b. (a -> b) -> a -> b
$ "uniBiCon: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Con -> String
forall a. Show a => a -> String
show Con
c
s :: Subst
s = [TyVarBndr] -> [Type] -> Subst
mkSubst [TyVarBndr]
tvs [Type]
ts
arm :: ([Pat] -> Pat)
-> [(a, Type)] -> StateT (Map Type Dec, Map Type Bool) Q Clause
arm c :: [Pat] -> Pat
c xs :: [(a, Type)]
xs = Type
-> Subst
-> ([Pat] -> Pat)
-> [Type]
-> StateT (Map Type Dec, Map Type Bool) Q Clause
mkArm Type
to Subst
s [Pat] -> Pat
c ([Type] -> StateT (Map Type Dec, Map Type Bool) Q Clause)
-> [Type] -> StateT (Map Type Dec, Map Type Bool) Q Clause
forall a b. (a -> b) -> a -> b
$ ((a, Type) -> Type) -> [(a, Type)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (a, Type) -> Type
forall a b. (a, b) -> b
snd [(a, Type)]
xs
if [Con] -> Bool
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
(Con -> StateT (Map Type Dec, Map Type Bool) Q Clause)
-> [Con] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> StateT (Map Type Dec, Map Type Bool) Q Clause
genArm [Con]
cons
mkArm :: Type -> Subst -> ([Pat] -> Pat) -> [Type] -> U Clause
mkArm :: Type
-> Subst
-> ([Pat] -> Pat)
-> [Type]
-> StateT (Map Type Dec, Map Type Bool) Q Clause
mkArm to :: Type
to s :: Subst
s c :: [Pat] -> Pat
c ts :: [Type]
ts = do
Name
r <- String -> U Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName "_r"
[Name]
vs <- (Type -> U Name)
-> [Type] -> StateT (Map Type Dec, Map Type Bool) Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (U Name -> Type -> U Name
forall a b. a -> b -> a
const (U Name -> Type -> U Name) -> U Name -> Type -> U Name
forall a b. (a -> b) -> a -> b
$ String -> U Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName "_x") [Type]
ts
let sub :: Name -> Type -> StateT (Map Type Dec, Map Type Bool) Q (Exp -> Exp)
sub v :: Name
v t :: Type
t = do
let t' :: Type
t' = Subst -> Type -> Type
subst Subst
s Type
t
Exp
uni <- Type -> Type -> StateT (Map Type Dec, Map Type Bool) Q Exp
uniBi Type
t' Type
to
(Exp -> Exp) -> StateT (Map Type Dec, Map Type Bool) Q (Exp -> Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Exp -> Exp)
-> StateT (Map Type Dec, Map Type Bool) Q (Exp -> Exp))
-> (Exp -> Exp)
-> StateT (Map Type Dec, Map Type Bool) Q (Exp -> Exp)
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 <- (Name
-> Type -> StateT (Map Type Dec, Map Type Bool) Q (Exp -> Exp))
-> [Name]
-> [Type]
-> StateT (Map Type Dec, Map Type Bool) Q [Exp -> Exp]
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 = ((Exp -> Exp) -> Exp -> Exp) -> Exp -> [Exp -> Exp] -> Exp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
($) (Name -> Exp
VarE Name
r) [Exp -> Exp]
es
Clause -> StateT (Map Type Dec, Map Type Bool) Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> StateT (Map Type Dec, Map Type Bool) Q Clause)
-> Clause -> StateT (Map Type Dec, Map Type Bool) Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [[Pat] -> Pat
c ((Name -> Pat) -> [Name] -> [Pat]
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)]
mkSubst :: [TyVarBndr] -> [Type] -> Subst
mkSubst :: [TyVarBndr] -> [Type] -> Subst
mkSubst vs :: [TyVarBndr]
vs ts :: [Type]
ts =
let vs' :: [Name]
vs' = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
un [TyVarBndr]
vs
un :: TyVarBndr -> Name
un (PlainTV v :: Name
v) = Name
v
un (KindedTV v :: Name
v _) = Name
v
in Bool -> Subst -> Subst
forall a. HasCallStack => Bool -> a -> a
assert ([Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
vs' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts) (Subst -> Subst) -> Subst -> Subst
forall a b. (a -> b) -> a -> b
$ [Name] -> [Type] -> Subst
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
vs' [Type]
ts
subst :: Subst -> Type -> Type
subst :: Subst -> Type -> Type
subst s :: Subst
s (ForallT v :: [TyVarBndr]
v c :: [Type]
c t :: Type
t) = [TyVarBndr] -> [Type] -> Type -> Type
ForallT [TyVarBndr]
v [Type]
c (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Subst -> Type -> Type
subst Subst
s Type
t
subst s :: Subst
s t :: Type
t@(VarT n :: Name
n) = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
t (Maybe Type -> Type) -> Maybe Type -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Subst -> Maybe Type
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n Subst
s
subst s :: Subst
s (AppT t1 :: Type
t1 t2 :: Type
t2) = Type -> Type -> Type
AppT (Subst -> Type -> Type
subst Subst
s Type
t1) (Subst -> Type -> Type
subst Subst
s Type
t2)
subst s :: Subst
s (SigT t :: Type
t k :: Type
k) = Type -> Type -> Type
SigT (Subst -> Type -> Type
subst Subst
s Type
t) Type
k
subst _ t :: Type
t = Type
t
getTyConInfo :: (Quasi q) => Name -> q ([TyVarBndr], [Con])
getTyConInfo :: Name -> q ([TyVarBndr], [Con])
getTyConInfo con :: Name
con = do
Info
info <- Name -> q Info
forall (m :: * -> *). Quasi m => Name -> m Info
qReify Name
con
case Info
info of
#if __GLASGOW_HASKELL__ <= 710
TyConI (DataD _ _ tvs cs _) -> return (tvs, cs)
TyConI (NewtypeD _ _ tvs c _) -> return (tvs, [c])
#else
TyConI (DataD _ _ tvs :: [TyVarBndr]
tvs _ cs :: [Con]
cs _) -> ([TyVarBndr], [Con]) -> q ([TyVarBndr], [Con])
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr]
tvs, [Con]
cs)
TyConI (NewtypeD _ _ tvs :: [TyVarBndr]
tvs _ c :: Con
c _) -> ([TyVarBndr], [Con]) -> q ([TyVarBndr], [Con])
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr]
tvs, [Con
c])
#endif
PrimTyConI{} -> ([TyVarBndr], [Con]) -> q ([TyVarBndr], [Con])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
i :: Info
i -> String -> q ([TyVarBndr], [Con])
forall a. String -> a
genError (String -> q ([TyVarBndr], [Con]))
-> String -> q ([TyVarBndr], [Con])
forall a b. (a -> b) -> a -> b
$ "unexpected TyCon: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Info -> String
forall a. Show a => a -> String
show Info
i
splitType :: (Quasi q) => Type -> q ([TyVarBndr], Type, Type)
splitType :: Type -> q ([TyVarBndr], Type, Type)
splitType t :: Type
t =
case Type
t of
(ForallT tvs :: [TyVarBndr]
tvs _ t :: Type
t) -> do
(tvs' :: [TyVarBndr]
tvs', from :: Type
from, to :: Type
to) <- Type -> q ([TyVarBndr], Type, Type)
forall (q :: * -> *).
Quasi q =>
Type -> q ([TyVarBndr], Type, Type)
splitType Type
t
([TyVarBndr], Type, Type) -> q ([TyVarBndr], Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr]
tvs [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ [TyVarBndr]
tvs', Type
from, Type
to)
(AppT (AppT ArrowT from :: Type
from) to :: Type
to) -> ([TyVarBndr], Type, Type) -> q ([TyVarBndr], Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Type
from, Type
to)
_ -> String -> q ([TyVarBndr], Type, Type)
forall a. String -> a
genError (String -> q ([TyVarBndr], Type, Type))
-> String -> q ([TyVarBndr], Type, Type)
forall a b. (a -> b) -> a -> b
$ "Type is not an arrow: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
t
getNameType :: (Quasi q) => Name -> q ([TyVarBndr], Type, Type)
getNameType :: Name -> q ([TyVarBndr], Type, Type)
getNameType name :: Name
name = do
Info
info <- Name -> q Info
forall (m :: * -> *). Quasi m => Name -> m Info
qReify Name
name
case Info
info of
#if __GLASGOW_HASKELL__ <= 710
VarI _ t _ _ -> splitType t
#else
VarI _ t :: Type
t _ -> Type -> q ([TyVarBndr], Type, Type)
forall (q :: * -> *).
Quasi q =>
Type -> q ([TyVarBndr], Type, Type)
splitType Type
t
#endif
_ -> String -> q ([TyVarBndr], Type, Type)
forall a. String -> a
genError (String -> q ([TyVarBndr], Type, Type))
-> String -> q ([TyVarBndr], Type, Type)
forall a b. (a -> b) -> a -> b
$ "Name is not variable: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Ppr a => a -> String
pprint Name
name
unList :: Type -> Type
unList :: Type -> Type
unList (AppT (ConT n :: Name
n) t :: Type
t) | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''[] = Type
t
unList (AppT ListT t :: Type
t) = Type
t
unList t :: Type
t = String -> Type
forall a. String -> a
genError (String -> Type) -> String -> Type
forall a b. (a -> b) -> a -> b
$ "universeBi: Type is not a list: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
t
splitTypeApp :: Type -> (Type, [Type])
splitTypeApp :: Type -> (Type, [Type])
splitTypeApp (AppT a :: Type
a r :: Type
r) = (Type
c, [Type]
rs [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
r]) where (c :: Type
c, rs :: [Type]
rs) = Type -> (Type, [Type])
splitTypeApp Type
a
splitTypeApp t :: Type
t = (Type
t, [])
expandSyn :: (Quasi q) => Type -> q Type
expandSyn :: Type -> q Type
expandSyn (ForallT tvs :: [TyVarBndr]
tvs ctx :: [Type]
ctx t :: Type
t) = (Type -> Type) -> q Type -> q Type
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([TyVarBndr] -> [Type] -> Type -> Type
ForallT [TyVarBndr]
tvs [Type]
ctx) (q Type -> q Type) -> q Type -> q Type
forall a b. (a -> b) -> a -> b
$ Type -> q Type
forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
t
expandSyn t :: Type
t@AppT{} = Type -> [Type] -> q Type
forall (q :: * -> *). Quasi q => Type -> [Type] -> q Type
expandSynApp Type
t []
expandSyn t :: Type
t@ConT{} = Type -> [Type] -> q Type
forall (q :: * -> *). Quasi q => Type -> [Type] -> q Type
expandSynApp Type
t []
expandSyn (SigT t :: Type
t k :: Type
k) = Type -> q Type
forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
t
expandSyn t :: Type
t = Type -> q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
expandSynApp :: (Quasi q) => Type -> [Type] -> q Type
expandSynApp :: Type -> [Type] -> q Type
expandSynApp (AppT t1 :: Type
t1 t2 :: Type
t2) ts :: [Type]
ts = do Type
t2' <- Type -> q Type
forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
t2; Type -> [Type] -> q Type
forall (q :: * -> *). Quasi q => Type -> [Type] -> q Type
expandSynApp Type
t1 (Type
t2'Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
ts)
expandSynApp (ConT n :: Name
n) ts :: [Type]
ts | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "[]" = Type -> q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> q Type) -> Type -> q Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
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 n :: Name
n) ts :: [Type]
ts = do
Info
info <- Name -> q Info
forall (m :: * -> *). Quasi m => Name -> m Info
qReify Name
n
case Info
info of
TyConI (TySynD _ tvs :: [TyVarBndr]
tvs rhs :: Type
rhs) ->
let (ts' :: [Type]
ts', ts'' :: [Type]
ts'') = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt ([TyVarBndr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr]
tvs) [Type]
ts
s :: Subst
s = [TyVarBndr] -> [Type] -> Subst
mkSubst [TyVarBndr]
tvs [Type]
ts'
rhs' :: Type
rhs' = Subst -> Type -> Type
subst Subst
s Type
rhs
in Type -> [Type] -> q Type
forall (q :: * -> *). Quasi q => Type -> [Type] -> q Type
expandSynApp Type
rhs' [Type]
ts''
_ -> Type -> q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> q Type) -> Type -> q Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
t [Type]
ts
expandSynApp t :: Type
t ts :: [Type]
ts = do Type
t' <- Type -> q Type
forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
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
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
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 :: String -> a
genError msg :: String
msg = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ "Data.Generics.Geniplate: " String -> ShowS
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 = (Exp -> Exp
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 e :: Exp
e = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Control.Monad.return) Exp
e
eap :: Exp -> Exp -> Exp
eap f :: Exp
f a :: 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 f :: Exp
f a :: 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 ra :: RetAp
ra stops :: [TypeQ]
stops = Name -> Q ([TyVarBndr], Type, Type)
forall (q :: * -> *).
Quasi q =>
Name -> q ([TyVarBndr], Type, Type)
getNameType (Name -> Q ([TyVarBndr], Type, Type))
-> (([TyVarBndr], Type, Type) -> Q Exp) -> Name -> Q Exp
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Mode -> RetAp -> [TypeQ] -> ([TyVarBndr], Type, Type) -> Q Exp
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' ra :: RetAp
ra stops :: [TypeQ]
stops q :: TypeQ
q = TypeQ
q TypeQ
-> (Type -> Q ([TyVarBndr], Type, Type))
-> Q ([TyVarBndr], Type, Type)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Q ([TyVarBndr], Type, Type)
forall (q :: * -> *).
Quasi q =>
Type -> q ([TyVarBndr], Type, Type)
splitType Q ([TyVarBndr], Type, Type)
-> (([TyVarBndr], Type, Type) -> Q Exp) -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Mode -> RetAp -> [TypeQ] -> ([TyVarBndr], Type, Type) -> Q Exp
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 :: Mode -> RetAp -> [TypeQ] -> (t, Type, Type) -> Q Exp
transformBiGsplit doDescend :: Mode
doDescend ra :: RetAp
ra stops :: [TypeQ]
stops (_tvs :: t
_tvs,fcn :: Type
fcn,res :: Type
res) = do
Name
f <- String -> Q Name
newName "_f"
Name
x <- String -> Q Name
newName "_x"
(ds :: [Dec]
ds, tr :: Exp
tr) <-
case (Type
fcn, Type
res) of
(AppT (AppT ArrowT s :: Type
s) s' :: Type
s', AppT (AppT ArrowT t :: Type
t) t' :: Type
t') | Type
s Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
s' Bool -> Bool -> Bool
&& Type
t Type -> Type -> Bool
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 ArrowT s :: Type
s) (AppT m :: Type
m s' :: Type
s'), AppT (AppT ArrowT t :: Type
t) (AppT m' :: Type
m' t' :: Type
t')) | Type
s Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
s' Bool -> Bool -> Bool
&& Type
t Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
t' Bool -> Bool -> Bool
&& Type
m Type -> Type -> Bool
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
_ -> String -> Q ([Dec], Exp)
forall a. String -> a
genError (String -> Q ([Dec], Exp)) -> String -> Q ([Dec], Exp)
forall a b. (a -> b) -> a -> b
$ "transformBi: malformed type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
ArrowT Type
fcn) Type
res) String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", 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] (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Dec] -> Exp -> Exp
LetE [Dec]
ds (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
tr (Name -> Exp
VarE Name
x)
Exp -> Q Exp
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 doDescend :: Mode
doDescend ra :: RetAp
ra stops :: [TypeQ]
stops f :: Name
f aft :: Type
aft st :: Type
st = do
[Type]
ss <- [TypeQ] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [TypeQ]
stops
Type
ft <- Type -> TypeQ
forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
aft
(tr :: Exp
tr, (m :: Map Type Dec
m, _)) <- StateT (Map Type Dec, Map Type Bool) Q Exp
-> (Map Type Dec, Map Type Bool)
-> Q (Exp, (Map Type Dec, Map Type Bool))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Bool
-> Mode
-> RetAp
-> Exp
-> Type
-> Type
-> StateT (Map Type Dec, Map Type Bool) Q Exp
trBi Bool
False Mode
doDescend RetAp
ra (Name -> Exp
VarE Name
f) Type
ft Type
st) (Map Type Dec
forall a b. Map a b
mEmpty, [(Type, Bool)] -> Map Type Bool
forall a b. [(a, b)] -> Map a b
mFromList ([(Type, Bool)] -> Map Type Bool)
-> [(Type, Bool)] -> Map Type Bool
forall a b. (a -> b) -> a -> b
$ [Type] -> [Bool] -> [(Type, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
ss (Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False))
([Dec], Exp) -> Q ([Dec], Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Type Dec -> [Dec]
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
-> StateT (Map Type Dec, Map Type Bool) Q Exp
trBi seenStop :: Bool
seenStop doDescend :: Mode
doDescend ra :: RetAp
ra@(ret :: Exp -> Exp
ret, _, rbind :: Exp -> Exp -> Exp
rbind) f :: Exp
f ft :: Type
ft ast :: Type
ast = do
(m :: Map Type Dec
m, c :: Map Type Bool
c) <- StateT
(Map Type Dec, Map Type Bool) Q (Map Type Dec, Map Type Bool)
forall s (m :: * -> *). MonadState s m => m s
get
Type
st <- Type -> StateT (Map Type Dec, Map Type Bool) Q Type
forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
ast
case Type -> Map Type Dec -> Maybe Dec
forall a b. Eq a => a -> Map a b -> Maybe b
mLookup Type
st Map Type Dec
m of
Just (FunD n :: Name
n _) -> do
if Mode
doDescend Mode -> Mode -> Bool
forall a. Eq a => a -> a -> Bool
== Mode
MDescend Bool -> Bool -> Bool
&& Type
ft Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
st then
Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
f
else
Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp)
-> Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
n
_ -> do
Name
tr <- String -> U Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName "_tr"
let mkRec :: Bool -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
mkRec same :: Bool
same = do
(Map Type Dec, Map Type Bool) -> U ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Type -> Dec -> Map Type Dec -> Map Type Dec
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 (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ [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 Type -> Type -> Bool
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 <- String -> U Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName "_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
((Map Type Dec, Map Type Bool) -> (Map Type Dec, Map Type Bool))
-> U ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Map Type Dec, Map Type Bool) -> (Map Type Dec, Map Type Bool))
-> U ())
-> ((Map Type Dec, Map Type Bool) -> (Map Type Dec, Map Type Bool))
-> U ()
forall a b. (a -> b) -> a -> b
$ \ (m' :: Map Type Dec
m', c' :: Map Type Bool
c') -> (Type -> Dec -> Map Type Dec -> Map Type Dec
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 <- String -> U Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName "_x"
let f' :: Exp -> Exp
f' = if Mode
doDescend Mode -> Mode -> Bool
forall a. Eq a => a -> a -> Bool
== Mode
MDescend then Exp -> Exp
forall a. a -> a
id else Exp -> Exp -> Exp
rbind Exp
f
[Clause] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
x] (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
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 <- String -> U Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName "_x"
[Clause] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
x] (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
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 <- String -> U Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName "_x"
[Clause] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
x] (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp
ret (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
x) []]
let d :: Dec
d = Name -> [Clause] -> Dec
FunD Name
tr [Clause]
cs
((Map Type Dec, Map Type Bool) -> (Map Type Dec, Map Type Bool))
-> U ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Map Type Dec, Map Type Bool) -> (Map Type Dec, Map Type Bool))
-> U ())
-> ((Map Type Dec, Map Type Bool) -> (Map Type Dec, Map Type Bool))
-> U ()
forall a b. (a -> b) -> a -> b
$ \ (m' :: Map Type Dec
m', c' :: Map Type Bool
c') -> (Type -> Dec -> Map Type Dec -> Map Type Dec
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')
Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp)
-> Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp
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 seenStop :: Bool
seenStop doDescend :: Mode
doDescend ra :: RetAp
ra f :: Exp
f ft :: Type
ft st :: Type
st = do
let (con :: Type
con, ts :: [Type]
ts) = Type -> (Type, [Type])
splitTypeApp Type
st
case Type
con of
ConT n :: 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 _ -> 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
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 ([Type] -> Type
forall a. [a] -> a
head [Type]
ts)
_ -> String -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
forall a. String -> a
genError (String -> StateT (Map Type Dec, Map Type Bool) Q [Clause])
-> String -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
forall a b. (a -> b) -> a -> b
$ "trBiCase: unexpected type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
st String -> ShowS
forall a. [a] -> [a] -> [a]
++ " (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
st String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"
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 seenStop :: Bool
seenStop doDescend :: Mode
doDescend ra :: RetAp
ra f :: Exp
f ft :: Type
ft st :: Type
st et :: Type
et = do
Clause
nil <- Bool
-> Mode
-> RetAp
-> Exp
-> Type
-> Type
-> Subst
-> ([Pat] -> Pat)
-> Exp
-> [Type]
-> StateT (Map Type Dec, Map Type Bool) Q Clause
trMkArm Bool
seenStop Mode
doDescend RetAp
ra Exp
f Type
ft Type
st [] (Pat -> [Pat] -> Pat
forall a b. a -> b -> a
const (Pat -> [Pat] -> Pat) -> Pat -> [Pat] -> Pat
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]
-> StateT (Map Type Dec, Map Type Bool) Q 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]
[Clause] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
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 seenStop :: Bool
seenStop doDescend :: Mode
doDescend ra :: RetAp
ra f :: Exp
f ft :: Type
ft st :: Type
st ts :: [Type]
ts = do
[Name]
vs <- (Type -> U Name)
-> [Type] -> StateT (Map Type Dec, Map Type Bool) Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (U Name -> Type -> U Name
forall a b. a -> b -> a
const (U Name -> Type -> U Name) -> U Name -> Type -> U Name
forall a b. (a -> b) -> a -> b
$ String -> U Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName "_t") [Type]
ts
#if __GLASGOW_HASKELL__ >= 810
let tupE = LamE (map VarP vs) $ TupE (map (Just . VarE) vs)
#else
let tupE :: Exp
tupE = [Pat] -> Exp -> Exp
LamE ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
vs) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
TupE ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
vs)
#endif
Clause
c <- Bool
-> Mode
-> RetAp
-> Exp
-> Type
-> Type
-> Subst
-> ([Pat] -> Pat)
-> Exp
-> [Type]
-> StateT (Map Type Dec, Map Type Bool) Q Clause
trMkArm Bool
seenStop Mode
doDescend RetAp
ra Exp
f Type
ft Type
st [] [Pat] -> Pat
TupP Exp
tupE [Type]
ts
[Clause] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
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 seenStop :: Bool
seenStop doDescend :: Mode
doDescend ra :: RetAp
ra f :: Exp
f con :: Name
con ft :: Type
ft st :: Type
st ts :: [Type]
ts = do
(tvs :: [TyVarBndr]
tvs, cons :: [Con]
cons) <- Name -> StateT (Map Type Dec, Map Type Bool) Q ([TyVarBndr], [Con])
forall (q :: * -> *). Quasi q => Name -> q ([TyVarBndr], [Con])
getTyConInfo Name
con
let genArm :: Con -> StateT (Map Type Dec, Map Type Bool) Q Clause
genArm (NormalC c :: Name
c xs :: [BangType]
xs) = ([Pat] -> Pat)
-> Exp
-> [BangType]
-> StateT (Map Type Dec, Map Type Bool) Q Clause
forall a.
([Pat] -> Pat)
-> Exp
-> [(a, Type)]
-> StateT (Map Type Dec, Map Type Bool) Q Clause
arm (Name -> [Pat] -> Pat
ConP Name
c) (Name -> Exp
ConE Name
c) [BangType]
xs
genArm (InfixC x1 :: BangType
x1 c :: Name
c x2 :: BangType
x2) = ([Pat] -> Pat)
-> Exp
-> [BangType]
-> StateT (Map Type Dec, Map Type Bool) Q Clause
forall a.
([Pat] -> Pat)
-> Exp
-> [(a, Type)]
-> StateT (Map Type Dec, Map Type Bool) Q Clause
arm (\ [p1 :: Pat
p1, p2 :: Pat
p2] -> Pat -> Name -> Pat -> Pat
InfixP Pat
p1 Name
c Pat
p2) (Name -> Exp
ConE Name
c) [BangType
x1, BangType
x2]
genArm (RecC c :: Name
c xs :: [VarBangType]
xs) = ([Pat] -> Pat)
-> Exp
-> [BangType]
-> StateT (Map Type Dec, Map Type Bool) Q Clause
forall a.
([Pat] -> Pat)
-> Exp
-> [(a, Type)]
-> StateT (Map Type Dec, Map Type Bool) Q Clause
arm (Name -> [Pat] -> Pat
ConP Name
c) (Name -> Exp
ConE Name
c) [ (Bang
b,Type
t) | (_,b :: Bang
b,t :: Type
t) <- [VarBangType]
xs ]
genArm c :: Con
c = String -> StateT (Map Type Dec, Map Type Bool) Q Clause
forall a. String -> a
genError (String -> StateT (Map Type Dec, Map Type Bool) Q Clause)
-> String -> StateT (Map Type Dec, Map Type Bool) Q Clause
forall a b. (a -> b) -> a -> b
$ "trBiCon: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Con -> String
forall a. Show a => a -> String
show Con
c
s :: Subst
s = [TyVarBndr] -> [Type] -> Subst
mkSubst [TyVarBndr]
tvs [Type]
ts
arm :: ([Pat] -> Pat)
-> Exp
-> [(a, Type)]
-> StateT (Map Type Dec, Map Type Bool) Q Clause
arm c :: [Pat] -> Pat
c ec :: Exp
ec xs :: [(a, Type)]
xs = Bool
-> Mode
-> RetAp
-> Exp
-> Type
-> Type
-> Subst
-> ([Pat] -> Pat)
-> Exp
-> [Type]
-> StateT (Map Type Dec, Map Type Bool) Q Clause
trMkArm Bool
seenStop Mode
doDescend RetAp
ra Exp
f Type
ft Type
st Subst
s [Pat] -> Pat
c Exp
ec ([Type] -> StateT (Map Type Dec, Map Type Bool) Q Clause)
-> [Type] -> StateT (Map Type Dec, Map Type Bool) Q Clause
forall a b. (a -> b) -> a -> b
$ ((a, Type) -> Type) -> [(a, Type)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (a, Type) -> Type
forall a b. (a, b) -> b
snd [(a, Type)]
xs
(Con -> StateT (Map Type Dec, Map Type Bool) Q Clause)
-> [Con] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> StateT (Map Type Dec, Map Type Bool) Q 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]
-> StateT (Map Type Dec, Map Type Bool) Q Clause
trMkArm seenStop :: Bool
seenStop doDescend :: Mode
doDescend ra :: RetAp
ra@(ret :: Exp -> Exp
ret, apl :: Exp -> Exp -> Exp
apl, _) f :: Exp
f ft :: Type
ft st :: Type
st s :: Subst
s c :: [Pat] -> Pat
c ec :: Exp
ec ts :: [Type]
ts = do
[Name]
vs <- (Type -> U Name)
-> [Type] -> StateT (Map Type Dec, Map Type Bool) Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (U Name -> Type -> U Name
forall a b. a -> b -> a
const (U Name -> Type -> U Name) -> U Name -> Type -> U Name
forall a b. (a -> b) -> a -> b
$ String -> U Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName "_x") [Type]
ts
let sub :: Name -> Type -> StateT (Map Type Dec, Map Type Bool) Q Exp
sub v :: Name
v t :: Type
t = do
if Bool
seenStop Bool -> Bool -> Bool
&& Mode
doDescend Mode -> Mode -> Bool
forall a. Eq a => a -> a -> Bool
== Mode
MDescendBi then do
Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp)
-> Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp
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
-> StateT (Map Type Dec, Map Type Bool) Q Exp
trBi Bool
seenStop Mode
doDescend RetAp
ra Exp
f Type
ft Type
t'
Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp)
-> Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
tr (Name -> Exp
VarE Name
v)
[Exp]
es <- (Name -> Type -> StateT (Map Type Dec, Map Type Bool) Q Exp)
-> [Name] -> [Type] -> StateT (Map Type Dec, Map Type Bool) Q [Exp]
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
sub [Name]
vs [Type]
ts
let body :: Exp
body = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
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
Clause -> StateT (Map Type Dec, Map Type Bool) Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> StateT (Map Type Dec, Map Type Bool) Q Clause)
-> Clause -> StateT (Map Type Dec, Map Type Bool) Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [[Pat] -> Pat
c ((Name -> Pat) -> [Name] -> [Pat]
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 :: Map a b
mEmpty = [(a, b)] -> Map a b
forall a b. [(a, b)] -> Map a b
Map []
mLookup :: (Eq a) => a -> Map a b -> Maybe b
mLookup :: a -> Map a b -> Maybe b
mLookup a :: a
a (Map xys :: [(a, b)]
xys) = a -> [(a, b)] -> Maybe b
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 :: a -> b -> Map a b -> Map a b
mInsert a :: a
a b :: b
b (Map xys :: [(a, b)]
xys) = [(a, b)] -> Map a b
forall a b. [(a, b)] -> Map a b
Map ([(a, b)] -> Map a b) -> [(a, b)] -> Map a b
forall a b. (a -> b) -> a -> b
$ (a
a, b
b) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: ((a, b) -> Bool) -> [(a, b)] -> [(a, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
a) (a -> Bool) -> ((a, b) -> a) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
forall a b. (a, b) -> a
fst) [(a, b)]
xys
mElems :: Map a b -> [b]
mElems :: Map a b -> [b]
mElems (Map xys :: [(a, b)]
xys) = ((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd [(a, b)]
xys
mFromList :: [(a, b)] -> Map a b
mFromList :: [(a, b)] -> Map a b
mFromList xys :: [(a, b)]
xys = [(a, b)] -> Map a b
forall a b. [(a, b)] -> Map a b
Map [(a, b)]
xys