{-# 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)
--import System.IO

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

---- Overloaded interface, same as Uniplate.

-- | Class for 'universeBi'.
class UniverseBi s t where
    universeBi :: s -> [t]

-- | Class for 'transformBi'.
class TransformBi s t where
    transformBi :: (s -> s) -> t -> t

-- | Class for 'transformBiM'.
class {-(Monad m) => -} TransformBiM m s t where
    transformBiM :: (s -> m s) -> t -> m t

-- | Class for 'descendBiM'.
class {-(Monad m) => -} DescendBiM m s t where
    descendBiM :: (s -> m s) -> t -> m t

-- | Class for 'descendM'.
class {-(Monad m) => -} 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 = a -> [a]
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 = (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 :: forall (m :: * -> *) a.
TransformBiM m a a =>
(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 :: forall a. DescendM Identity a => (a -> a) -> a -> a
descend 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 a. 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)

----

-- | Create a 'UniverseBi' instance.
-- The 'TypeQ' argument should be a pair; the /source/ and /target/ types for 'universeBi'.
instanceUniverseBi :: TypeQ         -- ^(source, target) types
                   -> Q [Dec]
instanceUniverseBi :: TypeQ -> Q [Dec]
instanceUniverseBi = [TypeQ] -> TypeQ -> Q [Dec]
instanceUniverseBiT []

-- | Create a 'UniverseBi' instance with certain types being abstract.
-- The 'TypeQ' argument should be a pair; the /source/ and /target/ types for 'universeBi'.
instanceUniverseBiT :: [TypeQ]      -- ^types not touched by 'universeBi'
                    -> TypeQ        -- ^(source, target) types
                    -> Q [Dec]
instanceUniverseBiT :: [TypeQ] -> TypeQ -> Q [Dec]
instanceUniverseBiT [TypeQ]
stops 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' [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 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_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 a. a -> Q a
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' [TypeQ]
_ Type
t = String -> Q [Dec]
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 Maybe Overlap
forall a. Maybe a
Nothing [] ((Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
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

-- | Create a 'TransformBi' instance.
-- The 'TypeQ' argument should be a pair; the /inner/ and /outer/ types for 'transformBi'.
instanceTransformBi :: TypeQ        -- ^(inner, outer) types
                    -> Q [Dec]
instanceTransformBi :: TypeQ -> Q [Dec]
instanceTransformBi = [TypeQ] -> TypeQ -> Q [Dec]
instanceTransformBiT []

-- | Create a 'TransformBi' instance with certain types being abstract.
-- The 'TypeQ' argument should be a pair; the /inner/ and /outer/ types for 'transformBi'.
instanceTransformBiT :: [TypeQ]      -- ^types not touched by 'transformBi'
                     -> TypeQ        -- ^(inner, outer) types
                     -> Q [Dec]
instanceTransformBiT :: [TypeQ] -> TypeQ -> Q [Dec]
instanceTransformBiT [TypeQ]
stops 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
$c== :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
/= :: 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
$ccompare :: Mode -> Mode -> Ordering
compare :: Mode -> Mode -> Ordering
$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
>= :: Mode -> Mode -> Bool
$cmax :: Mode -> Mode -> Mode
max :: Mode -> Mode -> Mode
$cmin :: Mode -> Mode -> Mode
min :: Mode -> Mode -> 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
$cshowsPrec :: Int -> Mode -> ShowS
showsPrec :: Int -> Mode -> ShowS
$cshow :: Mode -> String
show :: Mode -> String
$cshowList :: [Mode] -> ShowS
showList :: [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 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_f"
    Name
x <- String -> Q Name
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] (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 a. a -> Q a
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' Mode
_ [TypeQ]
_ Type
t = String -> Q [Dec]
forall a. String -> a
genError String
"instanceTransformBiT: the argument should be of the form [t| (S, T) |]"

-- | Create a 'DescendBiM' instance.
instanceDescendM :: TypeQ
                     -> TypeQ
                     -> Q [Dec]
instanceDescendM :: TypeQ -> TypeQ -> Q [Dec]
instanceDescendM = [TypeQ] -> TypeQ -> TypeQ -> Q [Dec]
instanceDescendMT []

-- | Create a 'DescendBiM' instance with certain types being abstract.
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 (Type -> Q [Dec]) -> TypeQ -> Q [Dec]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
ty

-- | Create a 'DescendBiM' instance.
instanceDescendBiM :: TypeQ
                     -> TypeQ
                     -> Q [Dec]
instanceDescendBiM :: TypeQ -> TypeQ -> Q [Dec]
instanceDescendBiM = [TypeQ] -> TypeQ -> TypeQ -> Q [Dec]
instanceDescendBiMT []

-- | Create a 'DescendBiM' instance with certain types being abstract.
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 (Type -> Q [Dec]) -> TypeQ -> Q [Dec]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
ty

-- | Create a 'TransformBiM' instance.
instanceTransformBiM :: TypeQ
                     -> TypeQ
                     -> Q [Dec]
instanceTransformBiM :: TypeQ -> TypeQ -> Q [Dec]
instanceTransformBiM = [TypeQ] -> TypeQ -> TypeQ -> Q [Dec]
instanceTransformBiMT []

-- | Create a 'TransformBiM' instance with certain types being abstract.
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 (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' 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 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_f"
    Name
x <- String -> Q Name
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] (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 a. a -> Q a
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' Mode
doDescend [TypeQ]
stops TypeQ
mndq Type
ty | (TupleT Int
_, [Type
ft, Type
st]) <- Type -> (Type, [Type])
splitTypeApp Type
ty = do
--    qRunIO $ do putStrLn "************"; hFlush stdout
    Type
mnd <- TypeQ
mndq

    Name
f <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_f"
    Name
x <- String -> Q Name
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] (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 Mode
MTransformBi -> ''TransformBiM; Mode
MDescendBi -> ''DescendBiM
        met :: Name
met = case Mode
doDescend of Mode
MTransformBi ->  'transformBiM; Mode
MDescendBi ->  'descendBiM
    [Dec] -> Q [Dec]
forall a. a -> Q a
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' Mode
_ [TypeQ]
_ TypeQ
_ Type
t = String -> Q [Dec]
forall a. String -> a
genError String
"instanceTransformBiMT: the argument should be of the form [t| (S, T) |]"


-- | Generate TH code for a function that extracts all subparts of a certain type.
-- The argument to 'genUniverseBi' is a name with the type @S -> [T]@, for some types
-- @S@ and @T@.  The function will extract all subparts of type @T@ from @S@.
genUniverseBi :: Name             -- ^function of type @S -> [T]@
              -> 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' []

-- | Same as 'genUniverseBi', but does not look inside any types mention in the
-- list of types.
genUniverseBiT :: [TypeQ]         -- ^types not touched by 'universeBi'
                -> Name            -- ^function of type @S -> [T]@
                -> Q Exp
genUniverseBiT :: [TypeQ] -> Name -> Q Exp
genUniverseBiT [TypeQ]
stops = Name -> Q ([TyVarBndr Specificity], Type, Type)
forall (q :: * -> *).
Quasi q =>
Name -> q ([TyVarBndr Specificity], Type, Type)
getNameType (Name -> Q ([TyVarBndr Specificity], Type, Type))
-> (([TyVarBndr Specificity], 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 Specificity], Type, Type) -> Q Exp
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 TypeQ
-> (Type -> Q ([TyVarBndr Specificity], Type, Type))
-> Q ([TyVarBndr Specificity], Type, Type)
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Q ([TyVarBndr Specificity], Type, Type)
forall (q :: * -> *).
Quasi q =>
Type -> q ([TyVarBndr Specificity], Type, Type)
splitType Q ([TyVarBndr Specificity], Type, Type)
-> (([TyVarBndr Specificity], Type, Type) -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [TypeQ] -> ([TyVarBndr Specificity], Type, Type) -> Q Exp
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
--    qRunIO $ print (from, to)
    ([Dec]
ds, Exp
f) <- [TypeQ] -> Type -> Type -> Q ([Dec], Exp)
uniBiQ [TypeQ]
stops Type
from Type
to
    Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_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 [])
--    qRunIO $ do putStrLn $ pprint e; hFlush stdout
    Exp -> Q Exp
forall a. a -> Q a
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 (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Type Dec, Map Type Bool) m a
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 Bool
b = Q () -> U ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Type Dec, Map Type Bool) m a
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 :: forall a. U a -> U a -> U a
qRecover = String -> U a -> U a -> U a
forall a. HasCallStack => String -> a
error String
"Data.Generics.Geniplate: qRecover not implemented"
    qReify :: Name -> U Info
qReify = Q Info -> U Info
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Type Dec, Map Type Bool) m a
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 MIN_VERSION_template_haskell(2,7,0)
    qReifyInstances :: Name -> [Type] -> U [Dec]
qReifyInstances Name
n = Q [Dec] -> U [Dec]
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Type Dec, Map Type Bool) m a
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 MIN_VERSION_template_haskell(2,5,0)
    qClassInstances n = lift . qClassInstances n
#endif
    qLocation :: U Loc
qLocation = Q Loc -> U Loc
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Type Dec, Map Type Bool) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Loc
forall (m :: * -> *). Quasi m => m Loc
qLocation
    qRunIO :: forall a. IO a -> U a
qRunIO = Q a -> StateT (Map Type Dec, Map Type Bool) Q a
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Type Dec, Map Type Bool) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q a -> StateT (Map Type Dec, Map Type Bool) Q a)
-> (IO a -> Q a)
-> IO a
-> StateT (Map Type Dec, Map Type Bool) Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> Q a
forall a. IO a -> Q a
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 = String -> U ()
forall a. HasCallStack => a
undefined -- lift . qAddForeignFilePath l
#elif MIN_VERSION_template_haskell(2,12,0)
    qAddForeignFile l   = undefined -- lift . qAddForeignFile l
#endif
#if MIN_VERSION_template_haskell(2,7,0)
    qLookupName :: Bool -> String -> U (Maybe Name)
qLookupName Bool
ns = Q (Maybe Name) -> U (Maybe Name)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Type Dec, Map Type Bool) m a
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 (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Type Dec, Map Type Bool) m a
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 MIN_VERSION_template_haskell(2,9,0)
    qReifyRoles :: Name -> U [Role]
qReifyRoles = Q [Role] -> U [Role]
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Type Dec, Map Type Bool) m a
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 :: forall a. Data a => AnnLookup -> U [a]
qReifyAnnotations = Q [a] -> StateT (Map Type Dec, Map Type Bool) Q [a]
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Type Dec, Map Type Bool) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [a] -> StateT (Map Type Dec, Map Type Bool) Q [a])
-> (AnnLookup -> Q [a])
-> AnnLookup
-> StateT (Map Type Dec, Map Type Bool) Q [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnLookup -> Q [a]
forall a. Data a => AnnLookup -> Q [a]
forall (m :: * -> *) a. (Quasi m, Data a) => AnnLookup -> m [a]
qReifyAnnotations
    qReifyModule :: Module -> U ModuleInfo
qReifyModule = Q ModuleInfo -> U ModuleInfo
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Type Dec, Map Type Bool) m a
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 (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Type Dec, Map Type Bool) m a
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 (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Type Dec, Map Type Bool) m a
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 :: forall a. Typeable a => U (Maybe a)
qGetQ = Q (Maybe a) -> StateT (Map Type Dec, Map Type Bool) Q (Maybe a)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Type Dec, Map Type Bool) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q (Maybe a)
forall a. Typeable a => Q (Maybe a)
forall (m :: * -> *) a. (Quasi m, Typeable a) => m (Maybe a)
qGetQ
    qPutQ :: forall a. Typeable a => a -> U ()
qPutQ = Q () -> U ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Type Dec, Map Type Bool) m a
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 a. Typeable a => a -> Q ()
forall (m :: * -> *) a. (Quasi m, Typeable a) => a -> m ()
qPutQ
#if MIN_VERSION_template_haskell(2,11,0)
    qReifyFixity :: Name -> U (Maybe Fixity)
qReifyFixity        = Name -> U (Maybe Fixity)
forall a. HasCallStack => a
undefined -- lift . qReifyFixity
    qReifyConStrictness :: Name -> U [DecidedStrictness]
qReifyConStrictness = Name -> U [DecidedStrictness]
forall a. HasCallStack => a
undefined -- lift . qReifyConStrictness
    qIsExtEnabled :: Extension -> U Bool
qIsExtEnabled       = Extension -> U Bool
forall a. HasCallStack => a
undefined -- lift . qIsExtEnabled
    qExtsEnabled :: U [Extension]
qExtsEnabled        = U [Extension]
forall a. HasCallStack => a
undefined -- lift (qExtsEnabled)
#if MIN_VERSION_template_haskell(2,13,0)
    qAddCorePlugin :: String -> U ()
qAddCorePlugin      = String -> U ()
forall a. HasCallStack => a
undefined -- lift . qAddCorePlugin
#if MIN_VERSION_template_haskell(2,14,0)
    qAddTempFile :: String -> U String
qAddTempFile        = String -> U String
forall a. HasCallStack => a
undefined -- lift . qAddTempFile
#if MIN_VERSION_template_haskell(2,16,0)
    qReifyType :: Name -> U Type
qReifyType          = Name -> U Type
forall a. HasCallStack => a
undefined -- lift . qReifyType
#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 <- [TypeQ] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [TypeQ]
stops
    Type
to <- Type -> TypeQ
forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
ato
    (Exp
f, (Map Type Dec
m, Map Type Bool
_)) <- 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 a. a -> Q a
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 Type
afrom Type
to = do
    (Map Type Dec
m, 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 -> U 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 Name
n [Clause]
_) -> Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp
forall a. a -> StateT (Map Type Dec, Map Type Bool) Q a
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
        Maybe Dec
_ -> do
            Name
f <- String -> U Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"_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
$ [Maybe Exp] -> Exp
TupE []) []]) Map Type Dec
m, Map Type Bool
c)   -- insert something to break recursion, will be replaced below.
                    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
                          -- Recursive data type, we need the current value and all values inside.
                          Name
g <- String -> U Name
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
                          -- Insert with a dummy type, just to get the definition in the map for mElems.
                          ((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
$ \ (Map Type Dec
m', 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 : $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
VarE Name
g)) _x _r |]
                       else
                          -- Non-recursive type, just use this value.
                          Q [Dec] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
unFun [d| f _x _r = _x : _r |]
                  else do
                      -- Types differ, look inside.
                      Bool
b <- Type -> Type -> U Bool
contains Type
to Type
from
                      if Bool
b then do
                          -- Occurrences inside, recurse.
                          StateT (Map Type Dec, Map Type Bool) Q [Clause]
mkRec
                       else
                          -- No occurrences of to inside from, so add nothing.
                          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
$ \ (Map Type Dec
m', 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 a. a -> StateT (Map Type Dec, Map Type Bool) Q a
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

-- Check if the second type is contained anywhere in the first type.
contains :: Type -> Type -> U Bool
contains :: Type -> Type -> U Bool
contains Type
to Type
afrom = do
--    qRunIO $ print ("contains", to, from)
    Type
from <- Type -> U 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 a. a -> StateT (Map Type Dec, Map Type Bool) Q a
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 Bool
b  -> Bool -> U Bool
forall a. a -> StateT (Map Type Dec, Map Type Bool) Q a
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 = [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 Type
u Type
_) = Type
tType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:Type -> [Type]
splits Type
u
    splits Type
t = [Type
t]

-- Check if the second type is contained somewhere inside the first.
contains' :: Type -> Type -> U Bool
contains' :: Type -> Type -> U Bool
contains' Type
to Type
from = do
--    qRunIO $ print ("contains'", to, from)
    let (Type
con, [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
$ \ (Map Type Dec
m, 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)        -- To make the fixpoint of the recursion False.
    Bool
b <- case Type
con of
         ConT Name
n    -> Name -> Type -> [Type] -> U Bool
containsCon Name
n Type
to [Type]
ts
         TupleT Int
_  -> ([Bool] -> Bool)
-> StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool
forall a b.
(a -> b)
-> StateT (Map Type Dec, Map Type Bool) Q a
-> StateT (Map Type Dec, Map Type Bool) Q b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Type -> Type -> U Bool
contains Type
to) [Type]
ts
         Type
ArrowT    -> Bool -> U Bool
forall a. a -> StateT (Map Type Dec, Map Type Bool) Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
         Type
ListT     -> if Type
to Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
from then Bool -> U Bool
forall a. a -> StateT (Map Type Dec, Map Type Bool) Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else Type -> Type -> U Bool
contains Type
to ([Type] -> Type
forall a. HasCallStack => [a] -> a
head [Type]
ts)
         VarT Name
_    -> Bool -> U Bool
forall a. a -> StateT (Map Type Dec, Map Type Bool) Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
         Type
t         -> String -> U Bool
forall a. String -> a
genError (String -> U Bool) -> String -> U Bool
forall a b. (a -> b) -> a -> b
$ String
"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
" (" 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]
++ String
")"
    ((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
$ \ (Map Type Dec
m, 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 a. a -> StateT (Map Type Dec, Map Type Bool) Q a
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
--    qRunIO $ print ("containsCon", con, to, ts)
    ([TyVarBndr ()]
tvs, [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 Name
_ [BangType]
xs) = ([Bool] -> Bool)
-> StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool
forall a b.
(a -> b)
-> StateT (Map Type Dec, Map Type Bool) Q a
-> StateT (Map Type Dec, Map Type Bool) Q b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 BangType
x1 Name
_ BangType
x2) = ([Bool] -> Bool)
-> StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool
forall a b.
(a -> b)
-> StateT (Map Type Dec, Map Type Bool) Q a
-> StateT (Map Type Dec, Map Type Bool) Q b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 Name
_ [VarBangType]
xs) = ([Bool] -> Bool)
-> StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool
forall a b.
(a -> b)
-> StateT (Map Type Dec, Map Type Bool) Q a
-> StateT (Map Type Dec, Map Type Bool) Q b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> U Bool
field [ Type
t | (Name
_,Bang
_,Type
t) <- [VarBangType]
xs ]
        conCon Con
c = String -> U Bool
forall a. String -> a
genError (String -> U Bool) -> String -> U Bool
forall a b. (a -> b) -> a -> b
$ String
"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
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)
    ([Bool] -> Bool)
-> StateT (Map Type Dec, Map Type Bool) Q [Bool] -> U Bool
forall a b.
(a -> b)
-> StateT (Map Type Dec, Map Type Bool) Q a
-> StateT (Map Type Dec, Map Type Bool) Q b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Con -> U Bool
conCon [Con]
cons

unFunD :: [Dec] -> [Clause]
unFunD :: [Dec] -> [Clause]
unFunD [FunD Name
_ [Clause]
cs] = [Clause]
cs
unFunD [Dec]
_ = String -> [Clause]
forall a. String -> a
genError (String -> [Clause]) -> String -> [Clause]
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 = Q [Clause] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Type Dec, Map Type Bool) m a
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 a b. (a -> b) -> Q a -> Q b
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
--        ArrowT    -> unFun [d| f _ _r = _r |]           -- Stop at functions
        Type
ListT     -> Type -> Type -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
uniBiList ([Type] -> Type
forall a. HasCallStack => [a] -> a
head [Type]
ts) Type
to
        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
$ String
"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
" (" 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]
++ 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 -> 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 = $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
uni) _x ($(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
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 = (Clause -> [Clause])
-> StateT (Map Type Dec, Map Type Bool) Q Clause
-> StateT (Map Type Dec, Map Type Bool) Q [Clause]
forall a b.
(a -> b)
-> StateT (Map Type Dec, Map Type Bool) Q a
-> StateT (Map Type Dec, Map Type Bool) Q b
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 Name
con [Type]
ts Type
to = do
    ([TyVarBndr ()]
tvs, [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 Name
c [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 BangType
x1 Name
c 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 (\ [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) = ([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) | (Name
_,Bang
b,Type
t) <- [VarBangType]
xs ]
        genArm 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
$ String
"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
forall a. [TyVarBndr a] -> [Type] -> Subst
mkSubst [TyVarBndr ()]
tvs [Type]
ts
        arm :: ([Pat] -> Pat)
-> [(a, Type)] -> StateT (Map Type Dec, Map Type Bool) Q Clause
arm [Pat] -> Pat
c [(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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Con]
cons then
        -- No constructurs, return nothing
        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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 Type
to Subst
s [Pat] -> Pat
c [Type]
ts = do
    Name
r <- String -> U Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"_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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 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 -> 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 a. a -> StateT (Map Type Dec, Map Type Bool) Q a
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 a b. (a -> b -> b) -> b -> [a] -> b
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 a. a -> StateT (Map Type Dec, Map Type Bool) Q a
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)]

#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' = (TyVarBndr a -> Name) -> [TyVarBndr a] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr a -> Name
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  Bool -> Subst -> Subst
forall a. HasCallStack => Bool -> a -> a
assert ([Name] -> Int
forall a. [a] -> 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 a. [a] -> 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 Subst
s (ForallT [TyVarBndr Specificity]
v [Type]
c Type
t) = [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
v [Type]
c (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Subst -> Type -> Type
subst Subst
s Type
t
subst Subst
s t :: Type
t@(VarT 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 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,21,0)
getTyConInfo :: (Quasi q) => Name -> q ([TyVarBndr BndrVis], [Con])
#elif 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 <- Name -> q 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]
_)   -> ([TyVarBndr ()], [Con]) -> q ([TyVarBndr ()], [Con])
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr ()]
tvs, [Con]
cs)
        TyConI (NewtypeD [Type]
_ Name
_ [TyVarBndr ()]
tvs Maybe Type
_ Con
c [DerivClause]
_) -> ([TyVarBndr ()], [Con]) -> q ([TyVarBndr ()], [Con])
forall a. a -> q a
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{} -> ([TyVarBndr ()], [Con]) -> q ([TyVarBndr ()], [Con])
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
        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
$ String
"unexpected TyCon: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Info -> String
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) <- Type -> q ([TyVarBndr Specificity], Type, Type)
forall (q :: * -> *).
Quasi q =>
Type -> q ([TyVarBndr Specificity], Type, Type)
splitType Type
t
      ([TyVarBndr Specificity], Type, Type)
-> q ([TyVarBndr Specificity], Type, Type)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr Specificity]
tvs [TyVarBndr Specificity]
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. [a] -> [a] -> [a]
++ [TyVarBndr Specificity]
tvs', Type
from, Type
to)
    (AppT (AppT Type
ArrowT Type
from) Type
to) -> ([TyVarBndr Specificity], Type, Type)
-> q ([TyVarBndr Specificity], Type, Type)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Type
from, Type
to)
    Type
_ -> String -> q ([TyVarBndr Specificity], Type, Type)
forall a. String -> a
genError (String -> q ([TyVarBndr Specificity], Type, Type))
-> String -> q ([TyVarBndr Specificity], Type, Type)
forall a b. (a -> b) -> a -> b
$ String
"Type is not an arrow: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
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 <- Name -> q 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
_  -> Type -> q ([TyVarBndr Specificity], Type, Type)
forall (q :: * -> *).
Quasi q =>
Type -> q ([TyVarBndr Specificity], Type, Type)
splitType Type
t
#else
        VarI _ t _ _ -> splitType t
#endif
        Info
_ -> String -> q ([TyVarBndr Specificity], Type, Type)
forall a. String -> a
genError (String -> q ([TyVarBndr Specificity], Type, Type))
-> String -> q ([TyVarBndr Specificity], Type, Type)
forall a b. (a -> b) -> a -> b
$ String
"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 Name
n) Type
t) | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''[] = Type
t
unList (AppT Type
ListT Type
t) = Type
t
unList Type
t = String -> Type
forall a. String -> a
genError (String -> Type) -> String -> Type
forall a b. (a -> b) -> a -> b
$ String
"universeBi: Type is not a list: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
t -- ++ " (" ++ show t ++ ")"

splitTypeApp :: Type -> (Type, [Type])
splitTypeApp :: Type -> (Type, [Type])
splitTypeApp (AppT Type
a Type
r) = (Type
c, [Type]
rs [Type] -> [Type] -> [Type]
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) = (Type -> Type) -> q Type -> q Type
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
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 Type
t Type
k) = Type -> q Type
forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
t   -- Ignore kind synonyms
expandSyn Type
t = Type -> q Type
forall a. a -> q a
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' <- 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 Name
n) [Type]
ts | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"[]" = Type -> q Type
forall a. a -> q a
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 b a. (b -> a -> b) -> 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 <- Name -> q 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'') = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt ([TyVarBndr ()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr ()]
tvs) [Type]
ts
                s :: Subst
s = [TyVarBndr ()] -> [Type] -> Subst
forall a. [TyVarBndr a] -> [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''
        Info
_ -> Type -> q Type
forall a. a -> q a
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 b a. (b -> a -> b) -> 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' <- Type -> q Type
forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
t; Type -> q Type
forall a. a -> q a
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 b a. (b -> a -> b) -> 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 = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Data.Generics.Geniplate: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg

----------------------------------------------------

-- Exp has type (S -> S) -> T -> T, for some S and T
-- | Generate TH code for a function that transforms all subparts of a certain type.
-- The argument to 'genTransformBi' is a name with the type @(S->S) -> T -> T@, for some types
-- @S@ and @T@.  The function will transform all subparts of type @S@ inside @T@ using the given function.
genTransformBi :: Name       -- ^function of type @(S->S) -> T -> T@
               -> 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' []

-- | Same as 'genTransformBi', but does not look inside any types mention in the
-- list of types.
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 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 = Name -> Q ([TyVarBndr Specificity], Type, Type)
forall (q :: * -> *).
Quasi q =>
Name -> q ([TyVarBndr Specificity], Type, Type)
getNameType (Name -> Q ([TyVarBndr Specificity], Type, Type))
-> (([TyVarBndr Specificity], 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 Specificity], 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' RetAp
ra [TypeQ]
stops TypeQ
q = TypeQ
q TypeQ
-> (Type -> Q ([TyVarBndr Specificity], Type, Type))
-> Q ([TyVarBndr Specificity], Type, Type)
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Q ([TyVarBndr Specificity], Type, Type)
forall (q :: * -> *).
Quasi q =>
Type -> q ([TyVarBndr Specificity], Type, Type)
splitType Q ([TyVarBndr Specificity], Type, Type)
-> (([TyVarBndr Specificity], Type, Type) -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Mode
-> RetAp
-> [TypeQ]
-> ([TyVarBndr Specificity], 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 :: 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 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_f"
    Name
x <- String -> Q Name
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 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 Type
ArrowT Type
s) (AppT Type
m Type
s'), AppT (AppT Type
ArrowT Type
t) (AppT Type
m' 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
            (Type, Type)
_ -> String -> Q ([Dec], Exp)
forall a. String -> a
genError (String -> Q ([Dec], Exp)) -> String -> Q ([Dec], Exp)
forall a b. (a -> b) -> a -> b
$ String
"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]
++ 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] (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)
--    qRunIO $ do putStrLn $ pprint e; hFlush stdout
    Exp -> Q Exp
forall a. a -> Q a
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 <- [TypeQ] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [TypeQ]
stops
    Type
ft <- Type -> TypeQ
forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
aft
    (Exp
tr, (Map Type Dec
m, Map Type Bool
_)) <- 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 a. a -> Q a
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)

--arrow :: Type -> Type -> Type
--arrow t1 t2 = AppT (AppT ArrowT t1) t2

trBi :: Bool -> Mode -> RetAp -> Exp -> Type -> Type -> U Exp
--trBi True DescendBiM (ret, _, _) _ _ _ = return ret
trBi :: Bool
-> Mode
-> RetAp
-> Exp
-> Type
-> Type
-> StateT (Map Type Dec, Map Type Bool) Q 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
--    qRunIO $ do print (seenStop, doDescend, ft, ast); hFlush stdout
    (Map Type Dec
m, 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 -> U Type
forall (q :: * -> *). Quasi q => Type -> q Type
expandSyn Type
ast
--    qRunIO $ print (ft, st)
{-
    if ft == st && seenStop && doDescend == MDescend then
      return f
     else
-}
    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 Name
n [Clause]
_) -> do
--            qRunIO $ print ("found", ft == st, seenStop, doDescend == MDescend)
            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 a. a -> StateT (Map Type Dec, Map Type Bool) Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
f
             else
                Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp
forall a. a -> StateT (Map Type Dec, Map Type Bool) Q a
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
        Maybe Dec
_ -> do
            Name
tr <- String -> U Name
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
--                    qRunIO $ do putStrLn $ "mkRec " ++ show (same, tr); hFlush stdout
                    (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
$ [Maybe Exp] -> Exp
TupE []) []]) Map Type Dec
m, Map Type Bool
c)  -- insert something to break recursion, will be replaced below.
                    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
--                      qRunIO $ do print ("equal", b, doDescend == MDescend, seenStop); hFlush stdout
                      if Bool
b then do
--                          qRunIO $ do putStrLn "create g"; hFlush stdout
                          Name
g <- String -> U Name
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
                          -- Insert with a dummy type, just to get the definition in the map for mElems.
                          ((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
$ \ (Map Type Dec
m', 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 String
"_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 a. a -> StateT (Map Type Dec, Map Type Bool) Q a
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
--                          qRunIO $ do putStrLn "call f"; hFlush stdout
                          Name
x <- String -> U Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"_x"
                          [Clause] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
forall a. a -> StateT (Map Type Dec, Map Type Bool) Q a
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
--                      qRunIO $ print (b, ft, 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 String
"_x"
                          [Clause] -> StateT (Map Type Dec, Map Type Bool) Q [Clause]
forall a. a -> StateT (Map Type Dec, Map Type Bool) Q a
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
$ \ (Map Type Dec
m', 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')  -- overwrite dummy binding from mkRec
            Exp -> StateT (Map Type Dec, Map Type Bool) Q Exp
forall a. a -> StateT (Map Type Dec, Map Type Bool) Q a
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 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
--        ArrowT    -> unFun [d| f _ _r = _r |]           -- Stop at functions
        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 ([Type] -> Type
forall a. HasCallStack => [a] -> a
head [Type]
ts)
        Type
_         -> 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
$ String
"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
" (" 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]
++ 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]
-> 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 a. a -> StateT (Map Type Dec, Map Type Bool) Q a
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 <- (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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 String
"_t") [Type]
ts
#if MIN_VERSION_template_haskell(2,16,0)
    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
$ [Maybe Exp] -> Exp
TupE ((Name -> Maybe Exp) -> [Name] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> (Name -> Exp) -> Name -> Maybe Exp
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]
-> 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 a. a -> StateT (Map Type Dec, Map Type Bool) Q a
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) <- 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 Name
c [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 BangType
x1 Name
c 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 (\ [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) = ([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) | (Name
_,Bang
b,Type
t) <- [VarBangType]
xs ]
        genArm 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
$ String
"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
forall a. [TyVarBndr a] -> [Type] -> Subst
mkSubst [TyVarBndr ()]
tvs [Type]
ts
        arm :: ([Pat] -> Pat)
-> Exp
-> [(a, Type)]
-> StateT (Map Type Dec, Map Type Bool) Q Clause
arm [Pat] -> Pat
c Exp
ec [(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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 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 <- (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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 String
"_x") [Type]
ts
    let sub :: Name -> Type -> StateT (Map Type Dec, Map Type Bool) Q Exp
sub Name
v Type
t = do
--            qRunIO $ print ("put", seenStop, doDescend, ft == st)
            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 a. a -> StateT (Map Type Dec, Map Type Bool) Q a
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 a. a -> StateT (Map Type Dec, Map Type Bool) Q a
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)
--        conTy = foldr arrow st (map (subst s) ts)
    [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 b a. (b -> a -> b) -> b -> [a] -> b
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 a. a -> StateT (Map Type Dec, Map Type Bool) Q a
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) []


----------------------------------------------------

-- Can't use Data.Map since TH stuff is not in Ord

newtype Map a b = Map [(a, b)]

mEmpty :: Map a b
mEmpty :: forall a b. 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 :: forall a b. Eq a => a -> Map a b -> Maybe b
mLookup a
a (Map [(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 :: forall a b. Eq a => a -> b -> Map a b -> Map a b
mInsert a
a b
b (Map [(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 :: forall a b. Map a b -> [b]
mElems (Map [(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 :: forall a b. [(a, b)] -> Map a b
mFromList [(a, b)]
xys = [(a, b)] -> Map a b
forall a b. [(a, b)] -> Map a b
Map [(a, b)]
xys