    {-# LANGUAGE CPP #-}
    #if __GLASGOW_HASKELL__ >= 800
    {-# OPTIONS_GHC -Wno-overlapping-patterns #-}
    #endif
    #if MIN_VERSION_template_haskell(2,12,0)
    {-# LANGUAGE Safe #-}
    #else
    {-# LANGUAGE Trustworthy #-}
    #endif
    #include "free-common.h"

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

    -- |

    -- Module      :  Control.Monad.Trans.TH

    -- Copyright   :  (C) 2008-2013 Edward Kmett

    -- License     :  BSD-style (see the file LICENSE)

    --

    -- Maintainer  :  Edward Kmett <ekmett@gmail.com>

    -- Stability   :  provisional

    -- Portability :  MPTCs, fundeps

    --

    -- Automatic generation of free monadic actions.

    --

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

    module Control.Monad.Free.TH
      (
       -- * Free monadic actions

       makeFree,
       makeFree_,
       makeFreeCon,
       makeFreeCon_,

       -- * Documentation

       -- $doc

       -- * Examples

       -- $examples

      ) where

    import Control.Arrow
    import Control.Monad
    import Data.Char (toLower)
    import Data.List ((\\), nub)
    import Language.Haskell.TH.Datatype.TyVarBndr
    import Language.Haskell.TH.Ppr (pprint)
    import Language.Haskell.TH.Syntax

    #if !(MIN_VERSION_base(4,8,0))
    import Control.Applicative
    #endif

    data Arg
      = Captured Type Exp
      | Param    Type
      deriving (Int -> Arg -> ShowS
    [Arg] -> ShowS
    Arg -> String
    (Int -> Arg -> ShowS)
    -> (Arg -> String) -> ([Arg] -> ShowS) -> Show Arg
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Arg -> ShowS
    showsPrec :: Int -> Arg -> ShowS
    $cshow :: Arg -> String
    show :: Arg -> String
    $cshowList :: [Arg] -> ShowS
    showList :: [Arg] -> ShowS
    Show)

    params :: [Arg] -> [Type]
    params :: [Arg] -> [Type]
    params [] = []
    params (Param Type
    t : [Arg]
    xs) = Type
    t Type -> [Type] -> [Type]
    forall a. a -> [a] -> [a]
    : [Arg] -> [Type]
    params [Arg]
    xs
    params (Arg
    _ : [Arg]
    xs) = [Arg] -> [Type]
    params [Arg]
    xs

    captured :: [Arg] -> [(Type, Exp)]
    captured :: [Arg] -> [(Type, Exp)]
    captured [] = []
    captured (Captured Type
    t Exp
    e : [Arg]
    xs) = (Type
    t, Exp
    e) (Type, Exp) -> [(Type, Exp)] -> [(Type, Exp)]
    forall a. a -> [a] -> [a]
    : [Arg] -> [(Type, Exp)]
    captured [Arg]
    xs
    captured (Arg
    _ : [Arg]
    xs) = [Arg] -> [(Type, Exp)]
    captured [Arg]
    xs

    zipExprs :: [Exp] -> [Exp] -> [Arg] -> [Exp]
    zipExprs :: [Exp] -> [Exp] -> [Arg] -> [Exp]
    zipExprs (Exp
    p:[Exp]
    ps) [Exp]
    cs (Param    Type
    _   : [Arg]
    as) = Exp
    p Exp -> [Exp] -> [Exp]
    forall a. a -> [a] -> [a]
    : [Exp] -> [Exp] -> [Arg] -> [Exp]
    zipExprs [Exp]
    ps [Exp]
    cs [Arg]
    as
    zipExprs [Exp]
    ps (Exp
    c:[Exp]
    cs) (Captured Type
    _ Exp
    _ : [Arg]
    as) = Exp
    c Exp -> [Exp] -> [Exp]
    forall a. a -> [a] -> [a]
    : [Exp] -> [Exp] -> [Arg] -> [Exp]
    zipExprs [Exp]
    ps [Exp]
    cs [Arg]
    as
    zipExprs [Exp]
    _ [Exp]
    _ [Arg]
    _ = []

    findTypeOrFail :: String -> Q Name
    findTypeOrFail :: String -> Q Name
    findTypeOrFail String
    s = String -> Q (Maybe Name)
    lookupTypeName String
    s Q (Maybe Name) -> (Maybe Name -> Q Name) -> Q Name
    forall a b. Q a -> (a -> Q b) -> Q b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Q Name -> (Name -> Q Name) -> Maybe Name -> Q Name
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (String -> Q Name
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q Name) -> String -> Q Name
    forall a b. (a -> b) -> a -> b
    $ String
    s String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    " is not in scope") Name -> Q Name
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return

    findValueOrFail :: String -> Q Name
    findValueOrFail :: String -> Q Name
    findValueOrFail String
    s = String -> Q (Maybe Name)
    lookupValueName String
    s Q (Maybe Name) -> (Maybe Name -> Q Name) -> Q Name
    forall a b. Q a -> (a -> Q b) -> Q b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Q Name -> (Name -> Q Name) -> Maybe Name -> Q Name
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (String -> Q Name
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q Name) -> String -> Q Name
    forall a b. (a -> b) -> a -> b
    $ String
    s String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "is not in scope") Name -> Q Name
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return

    -- | Pick a name for an operation.

    -- For normal constructors it lowers first letter.

    -- For infix ones it omits the first @:@.

    mkOpName :: String -> Q String
    mkOpName :: String -> Q String
    mkOpName (Char
    ':':String
    name) = String -> Q String
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    name
    mkOpName ( Char
    c :String
    name) = String -> Q String
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> Q String) -> String -> Q String
    forall a b. (a -> b) -> a -> b
    $ Char -> Char
    toLower Char
    c Char -> ShowS
    forall a. a -> [a] -> [a]
    : String
    name
    mkOpName String
    _ = String -> Q String
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "impossible happened: empty (null) constructor name"

    -- | Check if parameter is used in type.

    usesTV :: Name -> Type -> Bool
    usesTV :: Name -> Type -> Bool
    usesTV Name
    n (VarT Name
    name)  = Name
    n Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    name
    usesTV Name
    n (AppT Type
    t1 Type
    t2) = (Type -> Bool) -> [Type] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Name -> Type -> Bool
    usesTV Name
    n) [Type
    t1, Type
    t2]
    usesTV Name
    n (SigT Type
    t  Type
    _ ) = Name -> Type -> Bool
    usesTV Name
    n Type
    t
    usesTV Name
    n (ForallT [TyVarBndr Specificity]
    bs [Type]
    _ Type
    t) = Name -> Type -> Bool
    usesTV Name
    n Type
    t Bool -> Bool -> Bool
    && Name
    n Name -> [Name] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` (TyVarBndr Specificity -> Name)
    -> [TyVarBndr Specificity] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr Specificity -> Name
    forall flag. TyVarBndr_ flag -> Name
    tvName [TyVarBndr Specificity]
    bs
    usesTV Name
    _ Type
    _ = Bool
    False

    -- | Analyze constructor argument.

    mkArg :: Type -> Type -> Q Arg
    mkArg :: Type -> Type -> Q Arg
    mkArg (VarT Name
    n) Type
    t
      | Name -> Type -> Bool
    usesTV Name
    n Type
    t =
          case Type
    t of
            -- if parameter is used as is, the return type should be ()

            -- as well as the corresponding expression

            VarT Name
    _ -> Arg -> Q Arg
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Arg -> Q Arg) -> Arg -> Q Arg
    forall a b. (a -> b) -> a -> b
    $ Type -> Exp -> Arg
    Captured (Int -> Type
    TupleT Int
    0) ([Maybe Exp] -> Exp
    TupE [])
            -- if argument is of type (a1 -> ... -> aN -> param) then the

            -- return type is N-tuple (a1, ..., aN) and the corresponding

            -- expression is an N-tuple secion (,...,).

            AppT (AppT Type
    ArrowT Type
    _) Type
    _ -> do
              ([Type]
    ts, Name
    name) <- Type -> Q ([Type], Name)
    forall {m :: * -> *}. MonadFail m => Type -> m ([Type], Name)
    arrowsToTuple Type
    t
              Bool -> Q () -> Q ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when ((Type -> Bool) -> [Type] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Name -> Type -> Bool
    usesTV Name
    n) [Type]
    ts) (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $ String -> Q ()
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q ()) -> String -> Q ()
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unlines
                [ String
    "type variable " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Name -> String
    forall a. Ppr a => a -> String
    pprint Name
    n String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    " is forbidden"
                , String
    "in a type like (a1 -> ... -> aN -> " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Name -> String
    forall a. Ppr a => a -> String
    pprint Name
    n String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    ")"
                , String
    "in a constructor's argument type: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Ppr a => a -> String
    pprint Type
    t ]
              Bool -> Q () -> Q ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Name
    name Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Name
    n) (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $ String -> Q ()
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q ()) -> String -> Q ()
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unlines
                [ String
    "expected final return type `" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Name -> String
    forall a. Ppr a => a -> String
    pprint Name
    n String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "'"
                , String
    "but got `" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Name -> String
    forall a. Ppr a => a -> String
    pprint Name
    name String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "'"
                , String
    "in a constructor's argument type: `" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Ppr a => a -> String
    pprint Type
    t String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "'" ]
              let tup :: Type
    tup = [Type] -> Type
    nonUnaryTupleT [Type]
    ts
              [Name]
    xs <- (Type -> Q Name) -> [Type] -> 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 (Q Name -> Type -> Q Name
    forall a b. a -> b -> a
    const (Q Name -> Type -> Q Name) -> Q Name -> Type -> Q Name
    forall a b. (a -> b) -> a -> b
    $ String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "x") [Type]
    ts
              Arg -> Q Arg
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Arg -> Q Arg) -> Arg -> Q Arg
    forall a b. (a -> b) -> a -> b
    $ Type -> Exp -> Arg
    Captured Type
    tup ([Pat] -> Exp -> Exp
    LamE ((Name -> Pat) -> [Name] -> [Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Pat
    VarP [Name]
    xs) ([Exp] -> Exp
    nonUnaryTupE ([Exp] -> Exp) -> [Exp] -> Exp
    forall a b. (a -> b) -> a -> b
    $ (Name -> Exp) -> [Name] -> [Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Exp
    VarE [Name]
    xs))
            Type
    _ -> String -> Q Arg
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q Arg) -> String -> Q Arg
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unlines
                  [ String
    "expected a type variable `" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Name -> String
    forall a. Ppr a => a -> String
    pprint Name
    n String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "'"
                  , String
    "or a type like (a1 -> ... -> aN -> " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Name -> String
    forall a. Ppr a => a -> String
    pprint Name
    n String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    ")"
                  , String
    "but got `" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Ppr a => a -> String
    pprint Type
    t String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "'"
                  , String
    "in a constructor's argument" ]
      | Bool
    otherwise = Arg -> Q Arg
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Arg -> Q Arg) -> Arg -> Q Arg
    forall a b. (a -> b) -> a -> b
    $ Type -> Arg
    Param Type
    t
      where
        arrowsToTuple :: Type -> m ([Type], Name)
    arrowsToTuple (AppT (AppT Type
    ArrowT Type
    t1) Type
    t2) = do
          ([Type]
    ts, Name
    name) <- Type -> m ([Type], Name)
    arrowsToTuple Type
    t2
          ([Type], Name) -> m ([Type], Name)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type
    t1Type -> [Type] -> [Type]
    forall a. a -> [a] -> [a]
    :[Type]
    ts, Name
    name)
        arrowsToTuple (VarT Name
    name) = ([Type], Name) -> m ([Type], Name)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([], Name
    name)
        arrowsToTuple Type
    rt = String -> m ([Type], Name)
    forall a. String -> m a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> m ([Type], Name)) -> String -> m ([Type], Name)
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unlines
          [ String
    "expected final return type `" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Name -> String
    forall a. Ppr a => a -> String
    pprint Name
    n String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "'"
          , String
    "but got `" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Ppr a => a -> String
    pprint Type
    rt String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "'"
          , String
    "in a constructor's argument type: `" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Ppr a => a -> String
    pprint Type
    t String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "'" ]

        nonUnaryTupleT :: [Type] -> Type
        nonUnaryTupleT :: [Type] -> Type
    nonUnaryTupleT [Type
    t'] = Type
    t'
        nonUnaryTupleT [Type]
    ts   = (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 (Int -> Type
    TupleT (Int -> Type) -> Int -> Type
    forall a b. (a -> b) -> a -> b
    $ [Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Type]
    ts) [Type]
    ts

        nonUnaryTupE :: [Exp] -> Exp
        nonUnaryTupE :: [Exp] -> Exp
    nonUnaryTupE [Exp
    e] = Exp
    e
        nonUnaryTupE [Exp]
    es  = [Maybe Exp] -> Exp
    TupE ([Maybe Exp] -> Exp) -> [Maybe Exp] -> Exp
    forall a b. (a -> b) -> a -> b
    $
    #if MIN_VERSION_template_haskell(2,16,0)
                                  (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just
    #endif
                                  [Exp]
    es

    mkArg Type
    n Type
    _ = String -> Q Arg
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q Arg) -> String -> Q Arg
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unlines
      [ String
    "expected a type variable"
      , String
    "but got `" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Ppr a => a -> String
    pprint Type
    n String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "'"
      , String
    "as the last parameter of the type constructor" ]

    -- | Apply transformation to the return value independently of how many

    -- parameters does @e@ have.

    -- E.g. @mapRet Just (\x y z -> x + y * z)@ goes to

    -- @\x y z -> Just (x + y * z)@

    mapRet :: (Exp -> Exp) -> Exp -> Exp
    mapRet :: (Exp -> Exp) -> Exp -> Exp
    mapRet Exp -> Exp
    f (LamE [Pat]
    ps Exp
    e) = [Pat] -> Exp -> Exp
    LamE [Pat]
    ps (Exp -> Exp) -> Exp -> Exp
    forall a b. (a -> b) -> a -> b
    $ (Exp -> Exp) -> Exp -> Exp
    mapRet Exp -> Exp
    f Exp
    e
    mapRet Exp -> Exp
    f Exp
    e = Exp -> Exp
    f Exp
    e

    -- | Unification of two types.

    -- @next@ with @a -> next@ gives @Maybe a@ return type

    -- @a -> next@ with @b -> next@ gives @Either a b@ return type

    unifyT :: (Type, Exp) -> (Type, Exp) -> Q (Type, [Exp])
    unifyT :: (Type, Exp) -> (Type, Exp) -> Q (Type, [Exp])
    unifyT (TupleT Int
    0, Exp
    _) (TupleT Int
    0, Exp
    _) = String -> Q (Type, [Exp])
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "can't accept 2 mere parameters"
    unifyT (TupleT Int
    0, Exp
    _) (Type
    t, Exp
    e) = do
      Type
    maybe'   <- Name -> Type
    ConT (Name -> Type) -> Q Name -> Q Type
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> Q Name
    findTypeOrFail  String
    "Maybe"
      Exp
    nothing' <- Name -> Exp
    ConE (Name -> Exp) -> Q Name -> Q Exp
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> Q Name
    findValueOrFail String
    "Nothing"
      Exp
    just'    <- Name -> Exp
    ConE (Name -> Exp) -> Q Name -> Q Exp
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> Q Name
    findValueOrFail String
    "Just"
      (Type, [Exp]) -> Q (Type, [Exp])
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type -> Type -> Type
    AppT Type
    maybe' Type
    t, [Exp
    nothing', (Exp -> Exp) -> Exp -> Exp
    mapRet (Exp -> Exp -> Exp
    AppE Exp
    just') Exp
    e])
    unifyT (Type, Exp)
    x y :: (Type, Exp)
    y@(TupleT Int
    0, Exp
    _) = ([Exp] -> [Exp]) -> (Type, [Exp]) -> (Type, [Exp])
    forall b c d. (b -> c) -> (d, b) -> (d, c)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (d, b) (d, c)
    second [Exp] -> [Exp]
    forall a. [a] -> [a]
    reverse ((Type, [Exp]) -> (Type, [Exp]))
    -> Q (Type, [Exp]) -> Q (Type, [Exp])
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Type, Exp) -> (Type, Exp) -> Q (Type, [Exp])
    unifyT (Type, Exp)
    y (Type, Exp)
    x
    unifyT (Type
    t1, Exp
    e1) (Type
    t2, Exp
    e2) = do
      Type
    either' <- Name -> Type
    ConT (Name -> Type) -> Q Name -> Q Type
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> Q Name
    findTypeOrFail  String
    "Either"
      Exp
    left'   <- Name -> Exp
    ConE (Name -> Exp) -> Q Name -> Q Exp
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> Q Name
    findValueOrFail String
    "Left"
      Exp
    right'  <- Name -> Exp
    ConE (Name -> Exp) -> Q Name -> Q Exp
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> Q Name
    findValueOrFail String
    "Right"
      (Type, [Exp]) -> Q (Type, [Exp])
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type -> Type -> Type
    AppT (Type -> Type -> Type
    AppT Type
    either' Type
    t1) Type
    t2, [(Exp -> Exp) -> Exp -> Exp
    mapRet (Exp -> Exp -> Exp
    AppE Exp
    left') Exp
    e1, (Exp -> Exp) -> Exp -> Exp
    mapRet (Exp -> Exp -> Exp
    AppE Exp
    right') Exp
    e2])

    -- | Unifying a list of types (possibly refining expressions).

    -- Name is used when the return type is supposed to be arbitrary.

    unifyCaptured :: Name -> [(Type, Exp)] -> Q (Type, [Exp])
    unifyCaptured :: Name -> [(Type, Exp)] -> Q (Type, [Exp])
    unifyCaptured Name
    a []       = (Type, [Exp]) -> Q (Type, [Exp])
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Name -> Type
    VarT Name
    a, [])
    unifyCaptured Name
    _ [(Type
    t, Exp
    e)] = (Type, [Exp]) -> Q (Type, [Exp])
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type
    t, [Exp
    e])
    unifyCaptured Name
    _ [(Type, Exp)
    x, (Type, Exp)
    y]   = (Type, Exp) -> (Type, Exp) -> Q (Type, [Exp])
    unifyT (Type, Exp)
    x (Type, Exp)
    y
    unifyCaptured Name
    _ [(Type, Exp)]
    xs = String -> Q (Type, [Exp])
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q (Type, [Exp])) -> String -> Q (Type, [Exp])
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unlines
      [ String
    "can't unify more than 2 return types"
      , String
    "that use type parameter"
      , String
    "when unifying return types: "
      , [String] -> String
    unlines (((Type, Exp) -> String) -> [(Type, Exp)] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (Type -> String
    forall a. Ppr a => a -> String
    pprint (Type -> String) -> ((Type, Exp) -> Type) -> (Type, Exp) -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Type, Exp) -> Type
    forall a b. (a, b) -> a
    fst) [(Type, Exp)]
    xs) ]

    extractVars :: Type -> [Name]
    extractVars :: Type -> [Name]
    extractVars (ForallT [TyVarBndr Specificity]
    bs [Type]
    _ Type
    t) = Type -> [Name]
    extractVars Type
    t [Name] -> [Name] -> [Name]
    forall a. Eq a => [a] -> [a] -> [a]
    \\ (TyVarBndr Specificity -> Name)
    -> [TyVarBndr Specificity] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr Specificity -> Name
    forall flag. TyVarBndr_ flag -> Name
    tvName [TyVarBndr Specificity]
    bs
    extractVars (VarT Name
    n) = [Name
    n]
    extractVars (AppT Type
    x Type
    y) = Type -> [Name]
    extractVars Type
    x [Name] -> [Name] -> [Name]
    forall a. [a] -> [a] -> [a]
    ++ Type -> [Name]
    extractVars Type
    y
    #if MIN_VERSION_template_haskell(2,8,0)
    extractVars (SigT Type
    x Type
    k) = Type -> [Name]
    extractVars Type
    x [Name] -> [Name] -> [Name]
    forall a. [a] -> [a] -> [a]
    ++ Type -> [Name]
    extractVars Type
    k
    #else
    extractVars (SigT x k) = extractVars x
    #endif
    #if MIN_VERSION_template_haskell(2,11,0)
    extractVars (InfixT Type
    x Name
    _ Type
    y) = Type -> [Name]
    extractVars Type
    x [Name] -> [Name] -> [Name]
    forall a. [a] -> [a] -> [a]
    ++ Type -> [Name]
    extractVars Type
    y
    extractVars (UInfixT Type
    x Name
    _ Type
    y) = Type -> [Name]
    extractVars Type
    x [Name] -> [Name] -> [Name]
    forall a. [a] -> [a] -> [a]
    ++ Type -> [Name]
    extractVars Type
    y
    extractVars (ParensT Type
    x) = Type -> [Name]
    extractVars Type
    x
    #endif
    extractVars Type
    _ = []

    liftCon' :: Bool -> [TyVarBndrSpec] -> Cxt -> Type -> Type -> [Type] -> Name -> [Type] -> Q [Dec]
    liftCon' :: Bool
    -> [TyVarBndr Specificity]
    -> [Type]
    -> Type
    -> Type
    -> [Type]
    -> Name
    -> [Type]
    -> Q [Dec]
    liftCon' Bool
    typeSig [TyVarBndr Specificity]
    tvbs [Type]
    cx Type
    f Type
    n [Type]
    ns Name
    cn [Type]
    ts = do
      -- prepare some names

      Name
    opName <- String -> Name
    mkName (String -> Name) -> Q String -> Q Name
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> Q String
    mkOpName (Name -> String
    nameBase Name
    cn)
      Name
    m      <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "m"
      Name
    a      <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "a"
      Name
    monadFree <- String -> Q Name
    findTypeOrFail  String
    "MonadFree"
      Name
    liftF     <- String -> Q Name
    findValueOrFail String
    "liftF"
      -- look at the constructor parameters

      [Arg]
    args <- (Type -> Q Arg) -> [Type] -> Q [Arg]
    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 -> Q Arg
    mkArg Type
    n) [Type]
    ts
      let ps :: [Type]
    ps = [Arg] -> [Type]
    params [Arg]
    args    -- these are not using type parameter

          cs :: [(Type, Exp)]
    cs = [Arg] -> [(Type, Exp)]
    captured [Arg]
    args  -- these capture it somehow

      -- based on cs we get return type and refined expressions

      -- (e.g. with Nothing/Just or Left/Right tags)

      (Type
    retType, [Exp]
    es) <- Name -> [(Type, Exp)] -> Q (Type, [Exp])
    unifyCaptured Name
    a [(Type, Exp)]
    cs
      -- operation type is (a1 -> a2 -> ... -> aN -> m r)

      let opType :: Type
    opType  = (Type -> Type -> Type) -> Type -> [Type] -> Type
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (Type -> Type -> Type
    AppT (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> Type -> Type
    AppT Type
    ArrowT) (Type -> Type -> Type
    AppT (Name -> Type
    VarT Name
    m) Type
    retType) [Type]
    ps
      -- picking names for the implementation

      [Name]
    xs  <- (Type -> Q Name) -> [Type] -> 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 (Q Name -> Type -> Q Name
    forall a b. a -> b -> a
    const (Q Name -> Type -> Q Name) -> Q Name -> Type -> Q Name
    forall a b. (a -> b) -> a -> b
    $ String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "p") [Type]
    ps
      let pat :: [Pat]
    pat  = (Name -> Pat) -> [Name] -> [Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Pat
    VarP [Name]
    xs                      -- this is LHS

          exprs :: [Exp]
    exprs = [Exp] -> [Exp] -> [Arg] -> [Exp]
    zipExprs ((Name -> Exp) -> [Name] -> [Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Exp
    VarE [Name]
    xs) [Exp]
    es [Arg]
    args  -- this is what ctor would be applied to

          fval :: Exp
    fval = (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
    AppE (Name -> Exp
    ConE Name
    cn) [Exp]
    exprs       -- this is RHS without liftF

          ns' :: [Name]
    ns' = [Name] -> [Name]
    forall a. Eq a => [a] -> [a]
    nub ((Type -> [Name]) -> [Type] -> [Name]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap Type -> [Name]
    extractVars [Type]
    ns)
          q :: [TyVarBndr Specificity]
    q = (TyVarBndr Specificity -> Bool)
    -> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
    forall a. (a -> Bool) -> [a] -> [a]
    filter TyVarBndr Specificity -> Bool
    forall {flag}. TyVarBndr_ flag -> Bool
    nonNext [TyVarBndr Specificity]
    tvbs [TyVarBndr Specificity]
    -> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
    forall a. [a] -> [a] -> [a]
    ++ (Name -> TyVarBndr Specificity)
    -> [Name] -> [TyVarBndr Specificity]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> TyVarBndr Specificity
    plainTVSpecified ([Name]
    qa [Name] -> [Name] -> [Name]
    forall a. [a] -> [a] -> [a]
    ++ Name
    m Name -> [Name] -> [Name]
    forall a. a -> [a] -> [a]
    : [Name]
    ns')
          qa :: [Name]
    qa = case Type
    retType of VarT Name
    b | Name
    a Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    b -> [Name
    a]; Type
    _ -> []
          f' :: Type
    f' = (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
    f [Type]
    ns
      [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
    $ [[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat
        [ if Bool
    typeSig
    #if MIN_VERSION_template_haskell(2,10,0)
            then [ Name -> Type -> Dec
    SigD Name
    opName ([TyVarBndr Specificity] -> [Type] -> Type -> Type
    ForallT [TyVarBndr Specificity]
    q ([Type]
    cx [Type] -> [Type] -> [Type]
    forall a. [a] -> [a] -> [a]
    ++ [Name -> Type
    ConT Name
    monadFree Type -> Type -> Type
    `AppT` Type
    f' Type -> Type -> Type
    `AppT` Name -> Type
    VarT Name
    m]) Type
    opType) ]
    #else
            then [ SigD opName (ForallT q (cx ++ [ClassP monadFree [f', VarT m]]) opType) ]
    #endif
            else []
        , [ Name -> [Clause] -> Dec
    FunD Name
    opName [ [Pat] -> Body -> [Dec] -> Clause
    Clause [Pat]
    pat (Exp -> Body
    NormalB (Exp -> Body) -> Exp -> Body
    forall a b. (a -> b) -> a -> b
    $ Exp -> Exp -> Exp
    AppE (Name -> Exp
    VarE Name
    liftF) Exp
    fval) [] ] ] ]
      where
        nonNext :: TyVarBndr_ flag -> Bool
    nonNext TyVarBndr_ flag
    tv = Name -> Type
    VarT (TyVarBndr_ flag -> Name
    forall flag. TyVarBndr_ flag -> Name
    tvName TyVarBndr_ flag
    tv) Type -> Type -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Type
    n

    -- | Provide free monadic actions for a single value constructor.

    liftCon :: Bool -> [TyVarBndrSpec] -> Cxt -> Type -> Type -> [Type] -> Maybe [Name] -> Con -> Q [Dec]
    liftCon :: Bool
    -> [TyVarBndr Specificity]
    -> [Type]
    -> Type
    -> Type
    -> [Type]
    -> Maybe [Name]
    -> Con
    -> Q [Dec]
    liftCon Bool
    typeSig [TyVarBndr Specificity]
    ts [Type]
    cx Type
    f Type
    n [Type]
    ns Maybe [Name]
    onlyCons Con
    con
      | Bool -> Bool
    not ((Name -> Bool) -> [Name] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Name -> Maybe [Name] -> Bool
    forall a. Eq a => a -> Maybe [a] -> Bool
    `melem` Maybe [Name]
    onlyCons) (Con -> [Name]
    constructorNames Con
    con)) = [Dec] -> Q [Dec]
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
      | Bool
    otherwise = case Con
    con of
          NormalC Name
    cName [BangType]
    fields -> Bool
    -> [TyVarBndr Specificity]
    -> [Type]
    -> Type
    -> Type
    -> [Type]
    -> Name
    -> [Type]
    -> Q [Dec]
    liftCon' Bool
    typeSig [TyVarBndr Specificity]
    ts [Type]
    cx Type
    f Type
    n [Type]
    ns Name
    cName ([Type] -> Q [Dec]) -> [Type] -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ (BangType -> Type) -> [BangType] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map BangType -> Type
    forall a b. (a, b) -> b
    snd [BangType]
    fields
          RecC    Name
    cName [VarBangType]
    fields -> Bool
    -> [TyVarBndr Specificity]
    -> [Type]
    -> Type
    -> Type
    -> [Type]
    -> Name
    -> [Type]
    -> Q [Dec]
    liftCon' Bool
    typeSig [TyVarBndr Specificity]
    ts [Type]
    cx Type
    f Type
    n [Type]
    ns Name
    cName ([Type] -> Q [Dec]) -> [Type] -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ (VarBangType -> Type) -> [VarBangType] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Name
    _, Bang
    _, Type
    ty) -> Type
    ty) [VarBangType]
    fields
          InfixC  (Bang
    _,Type
    t1) Name
    cName (Bang
    _,Type
    t2) -> Bool
    -> [TyVarBndr Specificity]
    -> [Type]
    -> Type
    -> Type
    -> [Type]
    -> Name
    -> [Type]
    -> Q [Dec]
    liftCon' Bool
    typeSig [TyVarBndr Specificity]
    ts [Type]
    cx Type
    f Type
    n [Type]
    ns Name
    cName [Type
    t1, Type
    t2]
          ForallC [TyVarBndr Specificity]
    ts' [Type]
    cx' Con
    con' -> Bool
    -> [TyVarBndr Specificity]
    -> [Type]
    -> Type
    -> Type
    -> [Type]
    -> Maybe [Name]
    -> Con
    -> Q [Dec]
    liftCon Bool
    typeSig ([TyVarBndr Specificity]
    ts [TyVarBndr Specificity]
    -> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
    forall a. [a] -> [a] -> [a]
    ++ [TyVarBndr Specificity]
    ts') ([Type]
    cx [Type] -> [Type] -> [Type]
    forall a. [a] -> [a] -> [a]
    ++ [Type]
    cx') Type
    f Type
    n [Type]
    ns Maybe [Name]
    onlyCons Con
    con'
    #if MIN_VERSION_template_haskell(2,11,0)
          GadtC [Name]
    cNames [BangType]
    fields Type
    resType -> do
            [[Dec]]
    decs <- [Name] -> (Name -> Q [Dec]) -> Q [[Dec]]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM ((Name -> Bool) -> [Name] -> [Name]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Name -> Maybe [Name] -> Bool
    forall a. Eq a => a -> Maybe [a] -> Bool
    `melem` Maybe [Name]
    onlyCons) [Name]
    cNames) ((Name -> Q [Dec]) -> Q [[Dec]]) -> (Name -> Q [Dec]) -> Q [[Dec]]
    forall a b. (a -> b) -> a -> b
    $ \Name
    cName ->
                      Name
    -> [BangType]
    -> Type
    -> Bool
    -> [TyVarBndr Specificity]
    -> [Type]
    -> Type
    -> Q [Dec]
    liftGadtC Name
    cName [BangType]
    fields Type
    resType Bool
    typeSig [TyVarBndr Specificity]
    ts [Type]
    cx Type
    f
            [Dec] -> Q [Dec]
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[Dec]]
    decs)
          RecGadtC [Name]
    cNames [VarBangType]
    fields Type
    resType -> do
            let fields' :: [BangType]
    fields' = (VarBangType -> BangType) -> [VarBangType] -> [BangType]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Name
    _, Bang
    x, Type
    y) -> (Bang
    x, Type
    y)) [VarBangType]
    fields
            [[Dec]]
    decs <- [Name] -> (Name -> Q [Dec]) -> Q [[Dec]]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM ((Name -> Bool) -> [Name] -> [Name]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Name -> Maybe [Name] -> Bool
    forall a. Eq a => a -> Maybe [a] -> Bool
    `melem` Maybe [Name]
    onlyCons) [Name]
    cNames) ((Name -> Q [Dec]) -> Q [[Dec]]) -> (Name -> Q [Dec]) -> Q [[Dec]]
    forall a b. (a -> b) -> a -> b
    $ \Name
    cName ->
                      Name
    -> [BangType]
    -> Type
    -> Bool
    -> [TyVarBndr Specificity]
    -> [Type]
    -> Type
    -> Q [Dec]
    liftGadtC Name
    cName [BangType]
    fields' Type
    resType Bool
    typeSig [TyVarBndr Specificity]
    ts [Type]
    cx Type
    f
            [Dec] -> Q [Dec]
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[Dec]]
    decs)
    #endif
          Con
    _ -> String -> Q [Dec]
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q [Dec]) -> String -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ String
    "Unsupported constructor type: `" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Con -> String
    forall a. Ppr a => a -> String
    pprint Con
    con String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "'"

    #if MIN_VERSION_template_haskell(2,11,0)
    splitAppT :: Type -> (Type, [Type])
    splitAppT :: Type -> (Type, [Type])
    splitAppT Type
    ty = Type -> Type -> [Type] -> (Type, [Type])
    go Type
    ty Type
    ty []
      where
        go :: Type -> Type -> [Type] -> (Type, [Type])
        go :: Type -> Type -> [Type] -> (Type, [Type])
    go Type
    _      (AppT Type
    ty1 Type
    ty2)     [Type]
    args = Type -> Type -> [Type] -> (Type, [Type])
    go Type
    ty1 Type
    ty1 (Type
    ty2Type -> [Type] -> [Type]
    forall a. a -> [a] -> [a]
    :[Type]
    args)
        go Type
    origTy (SigT Type
    ty' Type
    _)       [Type]
    args = Type -> Type -> [Type] -> (Type, [Type])
    go Type
    origTy Type
    ty' [Type]
    args
        go Type
    origTy (InfixT Type
    ty1 Name
    n Type
    ty2) [Type]
    args = Type -> Type -> [Type] -> (Type, [Type])
    go Type
    origTy (Name -> Type
    ConT Name
    n Type -> Type -> Type
    `AppT` Type
    ty1 Type -> Type -> Type
    `AppT` Type
    ty2) [Type]
    args
        go Type
    origTy (ParensT Type
    ty')      [Type]
    args = Type -> Type -> [Type] -> (Type, [Type])
    go Type
    origTy Type
    ty' [Type]
    args
        go Type
    origTy Type
    _                  [Type]
    args = (Type
    origTy, [Type]
    args)

    liftGadtC :: Name -> [BangType] -> Type -> Bool -> [TyVarBndrSpec] -> Cxt -> Type -> Q [Dec]
    liftGadtC :: Name
    -> [BangType]
    -> Type
    -> Bool
    -> [TyVarBndr Specificity]
    -> [Type]
    -> Type
    -> Q [Dec]
    liftGadtC Name
    cName [BangType]
    fields Type
    resType Bool
    typeSig [TyVarBndr Specificity]
    ts [Type]
    cx Type
    f =
      Bool
    -> [TyVarBndr Specificity]
    -> [Type]
    -> Type
    -> Type
    -> [Type]
    -> Maybe [Name]
    -> Con
    -> Q [Dec]
    liftCon Bool
    typeSig [TyVarBndr Specificity]
    ts [Type]
    cx Type
    f Type
    nextTy ([Type] -> [Type]
    forall a. HasCallStack => [a] -> [a]
    init [Type]
    tys) Maybe [Name]
    forall a. Maybe a
    Nothing (Name -> [BangType] -> Con
    NormalC Name
    cName [BangType]
    fields)
      where
        (Type
    _f, [Type]
    tys) = Type -> (Type, [Type])
    splitAppT Type
    resType
        nextTy :: Type
    nextTy = [Type] -> Type
    forall a. HasCallStack => [a] -> a
    last [Type]
    tys
    #endif

    melem :: Eq a => a -> Maybe [a] -> Bool
    melem :: forall a. Eq a => a -> Maybe [a] -> Bool
    melem a
    _ Maybe [a]
    Nothing   = Bool
    True
    melem a
    x (Just [a]
    xs) = a
    x a -> [a] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [a]
    xs

    -- | Get construstor name(s).

    constructorNames :: Con -> [Name]
    constructorNames :: Con -> [Name]
    constructorNames (NormalC  Name
    name [BangType]
    _)    = [Name
    name]
    constructorNames (RecC     Name
    name [VarBangType]
    _)    = [Name
    name]
    constructorNames (InfixC   BangType
    _ Name
    name BangType
    _)  = [Name
    name]
    constructorNames (ForallC  [TyVarBndr Specificity]
    _ [Type]
    _ Con
    c)     = Con -> [Name]
    constructorNames Con
    c
    #if MIN_VERSION_template_haskell(2,11,0)
    constructorNames (GadtC [Name]
    names [BangType]
    _ Type
    _)    = [Name]
    names
    constructorNames (RecGadtC [Name]
    names [VarBangType]
    _ Type
    _) = [Name]
    names
    #endif
    constructorNames Con
    con' = String -> [Name]
    forall a. String -> [a]
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> [Name]) -> String -> [Name]
    forall a b. (a -> b) -> a -> b
    $ String
    "Unsupported constructor type: `" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Con -> String
    forall a. Ppr a => a -> String
    pprint Con
    con' String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "'"

    -- | Provide free monadic actions for a type declaration.

    liftDec :: Bool             -- ^ Include type signature?

            -> Maybe [Name]     -- ^ Include only mentioned constructor names. Use all constructors when @Nothing@.

            -> Dec              -- ^ Data type declaration.

            -> Q [Dec]
    #if MIN_VERSION_template_haskell(2,11,0)
    liftDec :: Bool -> Maybe [Name] -> Dec -> Q [Dec]
    liftDec Bool
    typeSig Maybe [Name]
    onlyCons (DataD [Type]
    _ Name
    tyName [TyVarBndr ()]
    tyVarBndrs Maybe Type
    _ [Con]
    cons [DerivClause]
    _)
    #else
    liftDec typeSig onlyCons (DataD _ tyName tyVarBndrs cons _)
    #endif
      | [TyVarBndr ()] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [TyVarBndr ()]
    tyVarBndrs = String -> Q [Dec]
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q [Dec]) -> String -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ String
    "Type constructor " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Name -> String
    forall a. Ppr a => a -> String
    pprint Name
    tyName String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    " needs at least one type parameter"
      | Bool
    otherwise = [[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Con -> Q [Dec]) -> [Con] -> Q [[Dec]]
    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 (Bool
    -> [TyVarBndr Specificity]
    -> [Type]
    -> Type
    -> Type
    -> [Type]
    -> Maybe [Name]
    -> Con
    -> Q [Dec]
    liftCon Bool
    typeSig [] [] Type
    con Type
    nextTy ([Type] -> [Type]
    forall a. HasCallStack => [a] -> [a]
    init [Type]
    tys) Maybe [Name]
    onlyCons) [Con]
    cons
        where
          tys :: [Type]
    tys     = (TyVarBndr () -> Type) -> [TyVarBndr ()] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (Name -> Type
    VarT (Name -> Type) -> (TyVarBndr () -> Name) -> TyVarBndr () -> Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TyVarBndr () -> Name
    forall flag. TyVarBndr_ flag -> Name
    tvName) [TyVarBndr ()]
    tyVarBndrs
          nextTy :: Type
    nextTy  = [Type] -> Type
    forall a. HasCallStack => [a] -> a
    last [Type]
    tys
          con :: Type
    con        = Name -> Type
    ConT Name
    tyName
    liftDec Bool
    _ Maybe [Name]
    _ Dec
    dec = String -> Q [Dec]
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q [Dec]) -> String -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unlines
      [ String
    "failed to derive makeFree operations:"
      , String
    "expected a data type constructor"
      , String
    "but got " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Dec -> String
    forall a. Ppr a => a -> String
    pprint Dec
    dec ]

    -- | Generate monadic actions for a data type.

    genFree :: Bool         -- ^ Include type signature?

            -> Maybe [Name] -- ^ Include only mentioned constructor names. Use all constructors when @Nothing@.

            -> Name         -- ^ Type name.

            -> Q [Dec]      -- ^ Generated declarations.

    genFree :: Bool -> Maybe [Name] -> Name -> Q [Dec]
    genFree Bool
    typeSig Maybe [Name]
    cnames Name
    tyCon = do
      Info
    info <- Name -> Q Info
    reify Name
    tyCon
      case Info
    info of
        TyConI Dec
    dec -> Bool -> Maybe [Name] -> Dec -> Q [Dec]
    liftDec Bool
    typeSig Maybe [Name]
    cnames Dec
    dec
        Info
    _ -> String -> Q [Dec]
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "makeFree expects a type constructor"

    -- | Generate monadic action for a single constructor of a data type.

    genFreeCon :: Bool         -- ^ Include type signature?

               -> Name         -- ^ Constructor name.

               -> Q [Dec]      -- ^ Generated declarations.

    genFreeCon :: Bool -> Name -> Q [Dec]
    genFreeCon Bool
    typeSig Name
    cname = do
      Info
    info <- Name -> Q Info
    reify Name
    cname
      case Info
    info of
        DataConI Name
    _ Type
    _ Name
    tname
    #if !(MIN_VERSION_template_haskell(2,11,0))
                           _
    #endif
                             -> Bool -> Maybe [Name] -> Name -> Q [Dec]
    genFree Bool
    typeSig ([Name] -> Maybe [Name]
    forall a. a -> Maybe a
    Just [Name
    cname]) Name
    tname
        Info
    _ -> String -> Q [Dec]
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q [Dec]) -> String -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unlines
              [ String
    "expected a data constructor"
              , String
    "but got " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Info -> String
    forall a. Ppr a => a -> String
    pprint Info
    info ]

    -- | @$('makeFree' ''T)@ provides free monadic actions for the

    -- constructors of the given data type @T@.

    makeFree :: Name -> Q [Dec]
    makeFree :: Name -> Q [Dec]
    makeFree = Bool -> Maybe [Name] -> Name -> Q [Dec]
    genFree Bool
    True Maybe [Name]
    forall a. Maybe a
    Nothing

    -- | Like 'makeFree', but does not provide type signatures.

    -- This can be used to attach Haddock comments to individual arguments

    -- for each generated function.

    --

    -- @

    -- data LangF x = Output String x

    --

    -- makeFree_ 'LangF

    --

    -- -- | Output a string.

    -- output :: MonadFree LangF m =>

    --           String   -- ^ String to output.

    --        -> m ()     -- ^ No result.

    -- @

    --

    -- 'makeFree_' must be called *before* the explicit type signatures.

    makeFree_ :: Name -> Q [Dec]
    makeFree_ :: Name -> Q [Dec]
    makeFree_ = Bool -> Maybe [Name] -> Name -> Q [Dec]
    genFree Bool
    False Maybe [Name]
    forall a. Maybe a
    Nothing

    -- | @$('makeFreeCon' 'Con)@ provides free monadic action for a data

    -- constructor @Con@. Note that you can attach Haddock comment to the

    -- generated function by placing it before the top-level invocation of

    -- 'makeFreeCon':

    --

    -- @

    -- -- | Output a string.

    -- makeFreeCon 'Output

    -- @

    makeFreeCon :: Name -> Q [Dec]
    makeFreeCon :: Name -> Q [Dec]
    makeFreeCon = Bool -> Name -> Q [Dec]
    genFreeCon Bool
    True

    -- | Like 'makeFreeCon', but does not provide a type signature.

    -- This can be used to attach Haddock comments to individual arguments.

    --

    -- @

    -- data LangF x = Output String x

    --

    -- makeFreeCon_ 'Output

    --

    -- -- | Output a string.

    -- output :: MonadFree LangF m =>

    --           String   -- ^ String to output.

    --        -> m ()     -- ^ No result.

    -- @

    --

    -- 'makeFreeCon_' must be called *before* the explicit type signature.

    makeFreeCon_ :: Name -> Q [Dec]
    makeFreeCon_ :: Name -> Q [Dec]
    makeFreeCon_ = Bool -> Name -> Q [Dec]
    genFreeCon Bool
    False

    {- $doc
     To generate free monadic actions from a @Type@, it must be a @data@
     declaration (maybe GADT) with at least one free variable. For each constructor of the type, a
     new function will be declared.

     Consider the following generalized definitions:

     > data Type a1 a2 … aN param = …
     >                            | FooBar t1 t2 t3 … tJ
     >                            | (:+) t1 t2 t3 … tJ
     >                            | t1 :* t2
     >                            | t1 `Bar` t2
     >                            | Baz { x :: t1, y :: t2, …, z :: tJ }
     >                            | forall b1 b2 … bN. cxt => Qux t1 t2 … tJ
     >                            | …

     where each of the constructor arguments @t1, …, tJ@ is either:

     1. A type, perhaps depending on some of the @a1, …, aN@.

     2. A type dependent on @param@, of the form @s1 -> … -> sM -> param@, M ≥ 0.
          At most 2 of the @t1, …, tJ@ may be of this form. And, out of these two,
          at most 1 of them may have @M == 0@; that is, be of the form @param@.

     For each constructor, a function will be generated. First, the name
     of the function is derived from the name of the constructor:

     * For prefix constructors, the name of the constructor with the first
       letter in lowercase (e.g. @FooBar@ turns into @fooBar@).

     * For infix constructors, the name of the constructor with the first
       character (a colon @:@), removed (e.g. @:+@ turns into @+@).

     Then, the type of the function is derived from the arguments to the constructor:

     > …
     > fooBar :: (MonadFree Type m) => t1' -> … -> tK' -> m ret
     > (+)    :: (MonadFree Type m) => t1' -> … -> tK' -> m ret
     > bar    :: (MonadFree Type m) => t1  -> … -> tK' -> m ret
     > baz    :: (MonadFree Type m) => t1' -> … -> tK' -> m ret
     > qux    :: (MonadFree Type m, cxt) => t1' -> … -> tK' -> m ret
     > …

     The @t1', …, tK'@ are those @t1@ … @tJ@ that only depend on the
     @a1, …, aN@.

     The type @ret@ depends on those constructor arguments that reference the
     @param@ type variable:

         1. If no arguments to the constructor depend on @param@, @ret ≡ a@, where
           @a@ is a fresh type variable.

         2. If only one argument in the constructor depends on @param@, then
           @ret ≡ (s1, …, sM)@. In particular, if @M == 0@, then @ret ≡ ()@; if @M == 1@, @ret ≡ s1@.

         3. If two arguments depend on @param@, (e.g. @u1 -> … -> uL -> param@ and
           @v1 -> … -> vM -> param@, then @ret ≡ Either (u1, …, uL) (v1, …, vM)@.

     Note that @Either a ()@ and @Either () a@ are both isomorphic to @Maybe a@.
     Because of this, when @L == 0@ or @M == 0@ in case 3., the type of
     @ret@ is simplified:

         * @ret ≡ Either (u1, …, uL) ()@ is rewritten to @ret ≡ Maybe (u1, …, uL)@.

         * @ret ≡ Either () (v1, …, vM)@ is rewritten to @ret ≡ Maybe (v1, …, vM)@.

    -}

    {- $examples

    <examples/Teletype.lhs Teletype> (regular data type declaration)

    <examples/RetryTH.hs Retry> (GADT declaration)

    -}