    {-# OPTIONS_GHC -fno-warn-orphans #-} -- TODO
    {-# LANGUAGE CPP                  #-}
    {-# LANGUAGE DeriveDataTypeable   #-}
    {-# LANGUAGE FlexibleContexts     #-}
    {-# LANGUAGE FlexibleInstances    #-}
    {-# LANGUAGE PatternGuards        #-}
    {-# LANGUAGE RankNTypes           #-}
    {-# LANGUAGE StandaloneDeriving   #-}
    {-# LANGUAGE TemplateHaskell      #-}
    {-# LANGUAGE TypeSynonymInstances #-}

    -- | This module is a staging ground
    -- for to-be-organized-and-merged-nicely code.

    module Language.Haskell.Meta.Utils (
        module Language.Haskell.Meta.Utils
    ) where

    import           Control.Monad
    import           Data.Generics                  hiding (Fixity)
    import           Data.List                      (findIndex)
    import           Language.Haskell.Exts.Pretty   (prettyPrint)
    import           Language.Haskell.Meta
    import qualified Language.Haskell.Meta.THCompat as Compat (conP, plainTV)
    import           Language.Haskell.TH.Lib        hiding (cxt)
    import           Language.Haskell.TH.Ppr
    import           Language.Haskell.TH.Syntax
    import           System.IO.Unsafe               (unsafePerformIO)
    import           Text.PrettyPrint

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

    dataDCons :: Dec -> [Con]
    dataDCons :: Dec -> [Con]
    dataDCons (DataD Cxt
    _ Name
    _ [TyVarBndr BndrVis]
    _ Maybe Type
    _ [Con]
    cons [DerivClause]
    _) = [Con]
    cons
    dataDCons Dec
    _                      = []

    decCons :: Dec -> [Con]
    decCons :: Dec -> [Con]
    decCons (DataD Cxt
    _ Name
    _ [TyVarBndr BndrVis]
    _ Maybe Type
    _ [Con]
    cons [DerivClause]
    _)   = [Con]
    cons
    decCons (NewtypeD Cxt
    _ Name
    _ [TyVarBndr BndrVis]
    _ Maybe Type
    _ Con
    con [DerivClause]
    _) = [Con
    con]
    decCons Dec
    _                        = []

    #if !MIN_VERSION_template_haskell(2,21,0)
    #if __GLASGOW_HASKELL__ < 900
    type TyVarBndrVis = TyVarBndr_ ()
    #else
    type TyVarBndrVis = TyVarBndrUnit
    #endif
    #endif

    decTyVars :: Dec -> [TyVarBndrVis]
    decTyVars :: Dec -> [TyVarBndr BndrVis]
    decTyVars (DataD Cxt
    _ Name
    _ [TyVarBndr BndrVis]
    ns Maybe Type
    _ [Con]
    _ [DerivClause]
    _)    = [TyVarBndr BndrVis]
    ns
    decTyVars (NewtypeD Cxt
    _ Name
    _ [TyVarBndr BndrVis]
    ns Maybe Type
    _ Con
    _ [DerivClause]
    _) = [TyVarBndr BndrVis]
    ns
    decTyVars (TySynD Name
    _ [TyVarBndr BndrVis]
    ns Type
    _)         = [TyVarBndr BndrVis]
    ns
    decTyVars (ClassD Cxt
    _ Name
    _ [TyVarBndr BndrVis]
    ns [FunDep]
    _ [Dec]
    _)     = [TyVarBndr BndrVis]
    ns
    decTyVars Dec
    _                       = []

    decName :: Dec -> Maybe Name
    decName :: Dec -> Maybe Name
    decName (FunD Name
    n [Clause]
    _)             = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    n
    decName (DataD Cxt
    _ Name
    n [TyVarBndr BndrVis]
    _ Maybe Type
    _ [Con]
    _ [DerivClause]
    _)    = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    n
    decName (NewtypeD Cxt
    _ Name
    n [TyVarBndr BndrVis]
    _ Maybe Type
    _ Con
    _ [DerivClause]
    _) = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    n
    decName (TySynD Name
    n [TyVarBndr BndrVis]
    _ Type
    _)         = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    n
    decName (ClassD Cxt
    _ Name
    n [TyVarBndr BndrVis]
    _ [FunDep]
    _ [Dec]
    _)     = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    n
    decName (SigD Name
    n Type
    _)             = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    n
    decName (ForeignD Foreign
    fgn)         = Name -> Maybe Name
    forall a. a -> Maybe a
    Just (Foreign -> Name
    foreignName Foreign
    fgn)
    decName Dec
    _                      = Maybe Name
    forall a. Maybe a
    Nothing

    foreignName :: Foreign -> Name
    foreignName :: Foreign -> Name
    foreignName (ImportF Callconv
    _ Safety
    _ String
    _ Name
    n Type
    _) = Name
    n
    foreignName (ExportF Callconv
    _ String
    _ Name
    n Type
    _)   = Name
    n

    cleanNames :: (Data a) => a -> a
    cleanNames :: forall a. Data a => a -> a
    cleanNames = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
    everywhere ((Name -> Name) -> a -> a
    forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
    mkT Name -> Name
    cleanName)
      where cleanName :: Name -> Name
            cleanName :: Name -> Name
    cleanName Name
    n
              | Name -> Bool
    isNameU Name
    n = Name
    n
              | Bool
    otherwise = (String -> Name
    mkName (String -> Name) -> (Name -> String) -> Name -> Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> String
    nameBase) Name
    n
            isNameU :: Name -> Bool
            isNameU :: Name -> Bool
    isNameU (Name OccName
    _ (NameU Uniq
    _)) = Bool
    True
            isNameU Name
    _                  = Bool
    False

    -- | The type passed in must have a @Show@ instance which
    --  produces a valid Haskell expression. Returns an empty
    --  @String@ if this is not the case. This is not TH-specific,
    --  but useful in general.
    pretty :: (Show a) => a -> String
    pretty :: forall a. Show a => a -> String
    pretty a
    a = case String -> Either String (Exp SrcSpanInfo)
    parseHsExp (a -> String
    forall a. Show a => a -> String
    show a
    a) of
                Left String
    _  -> []
                Right Exp SrcSpanInfo
    e -> Exp SrcSpanInfo -> String
    forall a. Pretty a => a -> String
    prettyPrint Exp SrcSpanInfo
    e

    pp :: (Data a, Ppr a) => a -> String
    pp :: forall a. (Data a, Ppr a) => a -> String
    pp = a -> String
    forall a. Ppr a => a -> String
    pprint (a -> String) -> (a -> a) -> a -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> a
    forall a. Data a => a -> a
    cleanNames

    ppDoc :: (Data a, Ppr a) => a -> Doc
    ppDoc :: forall a. (Data a, Ppr a) => a -> Doc
    ppDoc = String -> Doc
    text (String -> Doc) -> (a -> String) -> a -> Doc
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> String
    forall a. (Data a, Ppr a) => a -> String
    pp

    gpretty :: (Data a) => a -> String
    gpretty :: forall a. Data a => a -> String
    gpretty = (String -> String)
    -> (Exp SrcSpanInfo -> String)
    -> Either String (Exp SrcSpanInfo)
    -> String
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either (String -> String -> String
    forall a b. a -> b -> a
    const []) Exp SrcSpanInfo -> String
    forall a. Pretty a => a -> String
    prettyPrint (Either String (Exp SrcSpanInfo) -> String)
    -> (a -> Either String (Exp SrcSpanInfo)) -> a -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Either String (Exp SrcSpanInfo)
    parseHsExp (String -> Either String (Exp SrcSpanInfo))
    -> (a -> String) -> a -> Either String (Exp SrcSpanInfo)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> String
    forall a. Data a => a -> String
    gshow

    instance Show ExpQ where show :: ExpQ -> String
    show = Exp -> String
    forall a. Show a => a -> String
    show (Exp -> String) -> (ExpQ -> Exp) -> ExpQ -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Exp -> Exp
    forall a. Data a => a -> a
    cleanNames (Exp -> Exp) -> (ExpQ -> Exp) -> ExpQ -> Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ExpQ -> Exp
    forall a. Q a -> a
    unsafeRunQ
    instance Show (Q [Dec]) where show :: Q [Dec] -> String
    show = [String] -> String
    unlines ([String] -> String) -> (Q [Dec] -> [String]) -> Q [Dec] -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Dec -> String) -> [Dec] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Dec -> String
    forall a. Show a => a -> String
    show (Dec -> String) -> (Dec -> Dec) -> Dec -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Dec -> Dec
    forall a. Data a => a -> a
    cleanNames) ([Dec] -> [String]) -> (Q [Dec] -> [Dec]) -> Q [Dec] -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Q [Dec] -> [Dec]
    forall a. Q a -> a
    unsafeRunQ
    instance Show DecQ where show :: DecQ -> String
    show = Dec -> String
    forall a. Show a => a -> String
    show (Dec -> String) -> (DecQ -> Dec) -> DecQ -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Dec -> Dec
    forall a. Data a => a -> a
    cleanNames (Dec -> Dec) -> (DecQ -> Dec) -> DecQ -> Dec
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DecQ -> Dec
    forall a. Q a -> a
    unsafeRunQ
    instance Show TypeQ where show :: TypeQ -> String
    show = Type -> String
    forall a. Show a => a -> String
    show (Type -> String) -> (TypeQ -> Type) -> TypeQ -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> Type
    forall a. Data a => a -> a
    cleanNames (Type -> Type) -> (TypeQ -> Type) -> TypeQ -> Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TypeQ -> Type
    forall a. Q a -> a
    unsafeRunQ
    instance Show (Q String) where show :: Q String -> String
    show = Q String -> String
    forall a. Q a -> a
    unsafeRunQ
    instance Show (Q Doc) where show :: Q Doc -> String
    show = Doc -> String
    forall a. Show a => a -> String
    show (Doc -> String) -> (Q Doc -> Doc) -> Q Doc -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Q Doc -> Doc
    forall a. Q a -> a
    unsafeRunQ

    -- | @unsafeRunQ = unsafePerformIO . runQ@
    unsafeRunQ :: Q a -> a
    unsafeRunQ :: forall a. Q a -> a
    unsafeRunQ = IO a -> a
    forall a. IO a -> a
    unsafePerformIO (IO a -> a) -> (Q a -> IO a) -> Q a -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Q a -> IO a
    forall (m :: * -> *) a. Quasi m => Q a -> m a
    runQ

    nameToRawCodeStr :: Name -> String
    nameToRawCodeStr :: Name -> String
    nameToRawCodeStr Name
    n =
      let s :: String
    s = Name -> String
    showNameParens Name
    n
      in case Name -> Maybe NameSpace
    nameSpaceOf Name
    n of
          Just NameSpace
    VarName   -> String
    "'"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    s
          Just NameSpace
    DataName  -> String
    "'"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    s
          Just NameSpace
    TcClsName -> String
    "''"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    s
          Maybe NameSpace
    _              -> [String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [String
    "(mkName \"", (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /=Char
    '"') String
    s, String
    "\")"]
      where showNameParens :: Name -> String
            showNameParens :: Name -> String
    showNameParens Name
    n' =
              let nb :: String
    nb = Name -> String
    nameBase Name
    n'
              in case String
    nb of
                (Char
    c:String
    _) | Char -> Bool
    isSym Char
    c -> [String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [String
    "(",String
    nb,String
    ")"]
                String
    _               -> String
    nb
            isSym :: Char -> Bool
            isSym :: Char -> Bool
    isSym = (Char -> String -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` (String
    "><.\\/!@#$%^&*-+?:|" :: [Char]))

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

    (|$|) :: ExpQ -> ExpQ -> ExpQ
    infixr 0 |$|
    ExpQ
    f |$| :: ExpQ -> ExpQ -> ExpQ
    |$| ExpQ
    x = [|$ExpQ
    f $ExpQ
    x|]

    (|.|) :: ExpQ -> ExpQ -> ExpQ
    infixr 9 |.|
    ExpQ
    g |.| :: ExpQ -> ExpQ -> ExpQ
    |.| ExpQ
    f = [|$ExpQ
    g . $ExpQ
    f|]

    (|->|) :: TypeQ -> TypeQ -> TypeQ
    infixr 9 |->|
    TypeQ
    a |->| :: TypeQ -> TypeQ -> TypeQ
    |->| TypeQ
    b = TypeQ -> TypeQ -> TypeQ
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    appT (TypeQ -> TypeQ -> TypeQ
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    appT TypeQ
    forall (m :: * -> *). Quote m => m Type
    arrowT TypeQ
    a) TypeQ
    b

    unForall :: Type -> Type
    unForall :: Type -> Type
    unForall (ForallT [TyVarBndr Specificity]
    _ Cxt
    _ Type
    t) = Type
    t
    unForall Type
    t               = Type
    t

    functionT :: [TypeQ] -> TypeQ
    functionT :: [TypeQ] -> TypeQ
    functionT = (TypeQ -> TypeQ -> TypeQ) -> [TypeQ] -> TypeQ
    forall a. (a -> a -> a) -> [a] -> a
    forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
    foldl1 TypeQ -> TypeQ -> TypeQ
    (|->|)

    mkVarT :: String -> TypeQ
    mkVarT :: String -> TypeQ
    mkVarT = Name -> TypeQ
    forall (m :: * -> *). Quote m => Name -> m Type
    varT (Name -> TypeQ) -> (String -> Name) -> String -> TypeQ
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Name
    mkName

    -- | Infinite list of names composed of lowercase letters
    myNames :: [Name]
    myNames :: [Name]
    myNames = let xs :: [String]
    xs = (Char -> String) -> String -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Char -> String -> String
    forall a. a -> [a] -> [a]
    :[]) [Char
    'a'..Char
    'z']
                  ys :: [[String]]
    ys = ([String] -> [String]) -> [String] -> [[String]]
    forall a. (a -> a) -> a -> [a]
    iterate (([String] -> [String] -> [String]) -> [String] -> [String]
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
    join ((String -> String -> String) -> [String] -> [String] -> [String]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith String -> String -> String
    forall a. [a] -> [a] -> [a]
    (++))) [String]
    xs
               in (String -> Name) -> [String] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap String -> Name
    mkName ([[String]] -> [String]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[String]]
    ys)

    -- | Generalisation of renameTs
    renameThings :: (t1 -> t2 -> a1 -> (a2, t1, t2))
                 -> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2)
    renameThings :: forall t1 t2 a1 a2.
    (t1 -> t2 -> a1 -> (a2, t1, t2))
    -> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2)
    renameThings t1 -> t2 -> a1 -> (a2, t1, t2)
    _ t1
    env t2
    new [a2]
    acc [] = ([a2] -> [a2]
    forall a. [a] -> [a]
    reverse [a2]
    acc, t1
    env, t2
    new)
    renameThings t1 -> t2 -> a1 -> (a2, t1, t2)
    f t1
    env t2
    new [a2]
    acc (a1
    t:[a1]
    ts) =
      let (a2
    t', t1
    env', t2
    new') = t1 -> t2 -> a1 -> (a2, t1, t2)
    f t1
    env t2
    new a1
    t
      in (t1 -> t2 -> a1 -> (a2, t1, t2))
    -> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2)
    forall t1 t2 a1 a2.
    (t1 -> t2 -> a1 -> (a2, t1, t2))
    -> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2)
    renameThings t1 -> t2 -> a1 -> (a2, t1, t2)
    f t1
    env' t2
    new' (a2
    t'a2 -> [a2] -> [a2]
    forall a. a -> [a] -> [a]
    :[a2]
    acc) [a1]
    ts

    -- | renameT applied to a list of types
    renameTs :: [(Name, Name)] -> [Name] -> [Type] -> [Type]
      -> ([Type], [(Name,Name)], [Name])
    renameTs :: [(Name, Name)]
    -> [Name] -> Cxt -> Cxt -> (Cxt, [(Name, Name)], [Name])
    renameTs = ([(Name, Name)]
     -> [Name] -> Type -> (Type, [(Name, Name)], [Name]))
    -> [(Name, Name)]
    -> [Name]
    -> Cxt
    -> Cxt
    -> (Cxt, [(Name, Name)], [Name])
    forall t1 t2 a1 a2.
    (t1 -> t2 -> a1 -> (a2, t1, t2))
    -> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2)
    renameThings [(Name, Name)] -> [Name] -> Type -> (Type, [(Name, Name)], [Name])
    renameT

    -- | Rename type variables in the Type according to the given association
    -- list. Normalise constructor names (remove qualification, etc.)
    -- If a name is not found in the association list, replace it with one from
    -- the fresh names list, and add this translation to the returned list.
    -- The fresh names list should be infinite; myNames is a good example.
    renameT :: [(Name, Name)] -> [Name] -> Type -> (Type, [(Name,Name)], [Name])
    renameT :: [(Name, Name)] -> [Name] -> Type -> (Type, [(Name, Name)], [Name])
    renameT [(Name, Name)]
    _env [] Type
    _ = String -> (Type, [(Name, Name)], [Name])
    forall a. HasCallStack => String -> a
    error String
    "renameT: ran out of names!"
    renameT [(Name, Name)]
    env (Name
    x:[Name]
    new) (VarT Name
    n)
     | Just Name
    n' <- Name -> [(Name, Name)] -> Maybe Name
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Name
    n [(Name, Name)]
    env = (Name -> Type
    VarT Name
    n',[(Name, Name)]
    env,Name
    xName -> [Name] -> [Name]
    forall a. a -> [a] -> [a]
    :[Name]
    new)
     | Bool
    otherwise = (Name -> Type
    VarT Name
    x, (Name
    n,Name
    x)(Name, Name) -> [(Name, Name)] -> [(Name, Name)]
    forall a. a -> [a] -> [a]
    :[(Name, Name)]
    env, [Name]
    new)
    renameT [(Name, Name)]
    env [Name]
    new (ConT Name
    n) = (Name -> Type
    ConT (Name -> Name
    normaliseName Name
    n), [(Name, Name)]
    env, [Name]
    new)
    renameT [(Name, Name)]
    env [Name]
    new t :: Type
    t@(TupleT {}) = (Type
    t,[(Name, Name)]
    env,[Name]
    new)
    renameT [(Name, Name)]
    env [Name]
    new Type
    ArrowT = (Type
    ArrowT,[(Name, Name)]
    env,[Name]
    new)
    renameT [(Name, Name)]
    env [Name]
    new Type
    ListT = (Type
    ListT,[(Name, Name)]
    env,[Name]
    new)
    renameT [(Name, Name)]
    env [Name]
    new (AppT Type
    t Type
    t') = let (Type
    s,[(Name, Name)]
    env',[Name]
    new') = [(Name, Name)] -> [Name] -> Type -> (Type, [(Name, Name)], [Name])
    renameT [(Name, Name)]
    env [Name]
    new Type
    t
                                      (Type
    s',[(Name, Name)]
    env'',[Name]
    new'') = [(Name, Name)] -> [Name] -> Type -> (Type, [(Name, Name)], [Name])
    renameT [(Name, Name)]
    env' [Name]
    new' Type
    t'
                                  in (Type -> Type -> Type
    AppT Type
    s Type
    s', [(Name, Name)]
    env'', [Name]
    new'')
    renameT [(Name, Name)]
    env [Name]
    new (ForallT [TyVarBndr Specificity]
    ns Cxt
    cxt Type
    t) =
        let (Cxt
    ns',[(Name, Name)]
    env2,[Name]
    new2) = [(Name, Name)]
    -> [Name] -> Cxt -> Cxt -> (Cxt, [(Name, Name)], [Name])
    renameTs [(Name, Name)]
    env [Name]
    new [] ((TyVarBndr Specificity -> Type) -> [TyVarBndr Specificity] -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Name -> Type
    VarT (Name -> Type)
    -> (TyVarBndr Specificity -> Name) -> TyVarBndr Specificity -> Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TyVarBndr Specificity -> Name
    forall a. ToName a => a -> Name
    toName) [TyVarBndr Specificity]
    ns)
            ns'' :: [TyVarBndr Specificity]
    ns'' = (Type -> TyVarBndr Specificity) -> Cxt -> [TyVarBndr Specificity]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Type -> TyVarBndr Specificity
    unVarT Cxt
    ns'
            (Cxt
    cxt',[(Name, Name)]
    env3,[Name]
    new3) = [(Name, Name)]
    -> [Name] -> Cxt -> Cxt -> (Cxt, [(Name, Name)], [Name])
    renamePreds [(Name, Name)]
    env2 [Name]
    new2 [] Cxt
    cxt
            (Type
    t',[(Name, Name)]
    env4,[Name]
    new4) = [(Name, Name)] -> [Name] -> Type -> (Type, [(Name, Name)], [Name])
    renameT [(Name, Name)]
    env3 [Name]
    new3 Type
    t
        in ([TyVarBndr Specificity] -> Cxt -> Type -> Type
    ForallT [TyVarBndr Specificity]
    ns'' Cxt
    cxt' Type
    t', [(Name, Name)]
    env4, [Name]
    new4)
      where
        unVarT :: Type -> TyVarBndr Specificity
    unVarT (VarT Name
    n) = Name -> TyVarBndr Specificity
    Compat.plainTV Name
    n
        unVarT Type
    ty       = String -> TyVarBndr Specificity
    forall a. HasCallStack => String -> a
    error (String -> TyVarBndr Specificity)
    -> String -> TyVarBndr Specificity
    forall a b. (a -> b) -> a -> b
    $ String
    "renameT: unVarT: TODO for" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Show a => a -> String
    show Type
    ty
        renamePreds :: [(Name, Name)]
    -> [Name] -> Cxt -> Cxt -> (Cxt, [(Name, Name)], [Name])
    renamePreds = ([(Name, Name)]
     -> [Name] -> Type -> (Type, [(Name, Name)], [Name]))
    -> [(Name, Name)]
    -> [Name]
    -> Cxt
    -> Cxt
    -> (Cxt, [(Name, Name)], [Name])
    forall t1 t2 a1 a2.
    (t1 -> t2 -> a1 -> (a2, t1, t2))
    -> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2)
    renameThings [(Name, Name)] -> [Name] -> Type -> (Type, [(Name, Name)], [Name])
    renamePred
        renamePred :: [(Name, Name)] -> [Name] -> Type -> (Type, [(Name, Name)], [Name])
    renamePred = [(Name, Name)] -> [Name] -> Type -> (Type, [(Name, Name)], [Name])
    renameT
    renameT [(Name, Name)]
    _ [Name]
    _ Type
    t = String -> (Type, [(Name, Name)], [Name])
    forall a. HasCallStack => String -> a
    error (String -> (Type, [(Name, Name)], [Name]))
    -> String -> (Type, [(Name, Name)], [Name])
    forall a b. (a -> b) -> a -> b
    $ String
    "renameT: TODO for " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Show a => a -> String
    show Type
    t

    -- | Remove qualification, etc.
    normaliseName :: Name -> Name
    normaliseName :: Name -> Name
    normaliseName = String -> Name
    mkName (String -> Name) -> (Name -> String) -> Name -> Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> String
    nameBase

    applyT :: Type -> Type -> Type
    applyT :: Type -> Type -> Type
    applyT (ForallT [] Cxt
    _ Type
    t) Type
    t' = Type
    t Type -> Type -> Type
    `AppT` Type
    t'
    applyT (ForallT (TyVarBndr Specificity
    n:[TyVarBndr Specificity]
    ns) Cxt
    cxt Type
    t) Type
    t' = [TyVarBndr Specificity] -> Cxt -> Type -> Type
    ForallT [TyVarBndr Specificity]
    ns Cxt
    cxt
      ([(Name, Type)] -> [Name] -> Type -> Type
    substT [(TyVarBndr Specificity -> Name
    forall a. ToName a => a -> Name
    toName TyVarBndr Specificity
    n,Type
    t')] ((TyVarBndr Specificity -> Name)
    -> [TyVarBndr Specificity] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap TyVarBndr Specificity -> Name
    forall a. ToName a => a -> Name
    toName [TyVarBndr Specificity]
    ns) Type
    t)
    applyT Type
    t Type
    t' = Type
    t Type -> Type -> Type
    `AppT` Type
    t'

    substT :: [(Name, Type)] -> [Name] -> Type -> Type
    substT :: [(Name, Type)] -> [Name] -> Type -> Type
    substT [(Name, Type)]
    env [Name]
    bnd (ForallT [TyVarBndr Specificity]
    ns Cxt
    _ Type
    t) = [(Name, Type)] -> [Name] -> Type -> Type
    substT [(Name, Type)]
    env ((TyVarBndr Specificity -> Name)
    -> [TyVarBndr Specificity] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap TyVarBndr Specificity -> Name
    forall a. ToName a => a -> Name
    toName [TyVarBndr Specificity]
    ns[Name] -> [Name] -> [Name]
    forall a. [a] -> [a] -> [a]
    ++[Name]
    bnd) Type
    t
    substT [(Name, Type)]
    env [Name]
    bnd t :: Type
    t@(VarT Name
    n)
      | Name
    n Name -> [Name] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Name]
    bnd = Type
    t
      | Bool
    otherwise = Type -> (Type -> Type) -> Maybe Type -> Type
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Type
    t Type -> Type
    forall a. a -> a
    id (Name -> [(Name, Type)] -> Maybe Type
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Name
    n [(Name, Type)]
    env)
    substT [(Name, Type)]
    env [Name]
    bnd (AppT Type
    t Type
    t') = Type -> Type -> Type
    AppT ([(Name, Type)] -> [Name] -> Type -> Type
    substT [(Name, Type)]
    env [Name]
    bnd Type
    t)
                                      ([(Name, Type)] -> [Name] -> Type -> Type
    substT [(Name, Type)]
    env [Name]
    bnd Type
    t')
    substT [(Name, Type)]
    _ [Name]
    _ Type
    t = Type
    t

    splitCon :: Con -> (Name,[Type])
    splitCon :: Con -> (Name, Cxt)
    splitCon Con
    c = (Con -> Name
    conName Con
    c, Con -> Cxt
    conTypes Con
    c)

    strictTypeTy :: StrictType -> Type
    strictTypeTy :: StrictType -> Type
    strictTypeTy (Bang
    _,Type
    t) = Type
    t

    varStrictTypeTy :: VarStrictType -> Type
    varStrictTypeTy :: VarStrictType -> Type
    varStrictTypeTy (Name
    _,Bang
    _,Type
    t) = Type
    t

    conTypes :: Con -> [Type]
    conTypes :: Con -> Cxt
    conTypes (NormalC Name
    _ [StrictType]
    sts) = (StrictType -> Type) -> [StrictType] -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap StrictType -> Type
    strictTypeTy [StrictType]
    sts
    conTypes (RecC    Name
    _ [VarStrictType]
    vts) = (VarStrictType -> Type) -> [VarStrictType] -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap VarStrictType -> Type
    varStrictTypeTy [VarStrictType]
    vts
    conTypes (InfixC StrictType
    t Name
    _ StrictType
    t') = (StrictType -> Type) -> [StrictType] -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap StrictType -> Type
    strictTypeTy [StrictType
    t,StrictType
    t']
    conTypes (ForallC [TyVarBndr Specificity]
    _ Cxt
    _ Con
    c) = Con -> Cxt
    conTypes Con
    c
    conTypes Con
    c               = String -> Cxt
    forall a. HasCallStack => String -> a
    error (String -> Cxt) -> String -> Cxt
    forall a b. (a -> b) -> a -> b
    $ String
    "conTypes: TODO for " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Con -> String
    forall a. Show a => a -> String
    show Con
    c
    -- TODO
                -- (GadtC _ _ _)
                -- (RecGadtC _ _ _)

    conToConType :: Type -> Con -> Type
    conToConType :: Type -> Con -> Type
    conToConType Type
    ofType Con
    con = (Type -> Type -> Type) -> Type -> Cxt -> 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
    a Type
    b -> Type -> Type -> Type
    AppT (Type -> Type -> Type
    AppT Type
    ArrowT Type
    a) Type
    b) Type
    ofType (Con -> Cxt
    conTypes Con
    con)

    unwindT :: Type -> [Type]
    unwindT :: Type -> Cxt
    unwindT = Type -> Cxt
    go
      where go :: Type -> [Type]
            go :: Type -> Cxt
    go (ForallT [TyVarBndr Specificity]
    _ Cxt
    _ Type
    t)           = Type -> Cxt
    go Type
    t
            go (AppT (AppT Type
    ArrowT Type
    t) Type
    t') = Type
    t Type -> Cxt -> Cxt
    forall a. a -> [a] -> [a]
    : Type -> Cxt
    go Type
    t'
            go Type
    _                         = []

    unwindE :: Exp -> [Exp]
    unwindE :: Exp -> [Exp]
    unwindE = [Exp] -> Exp -> [Exp]
    go []
      where go :: [Exp] -> Exp -> [Exp]
    go [Exp]
    acc (Exp
    e `AppE` Exp
    e') = [Exp] -> Exp -> [Exp]
    go (Exp
    e'Exp -> [Exp] -> [Exp]
    forall a. a -> [a] -> [a]
    :[Exp]
    acc) Exp
    e
            go [Exp]
    acc Exp
    e             = Exp
    eExp -> [Exp] -> [Exp]
    forall a. a -> [a] -> [a]
    :[Exp]
    acc

    -- | The arity of a Type.
    arityT :: Type -> Int
    arityT :: Type -> Int
    arityT = Int -> Type -> Int
    go Int
    0
      where go :: Int -> Type -> Int
            go :: Int -> Type -> Int
    go Int
    n (ForallT [TyVarBndr Specificity]
    _ Cxt
    _ Type
    t) = Int -> Type -> Int
    go Int
    n Type
    t
            go Int
    n (AppT (AppT Type
    ArrowT Type
    _) Type
    t) =
              let n' :: Int
    n' = Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1 in Int
    n' Int -> Int -> Int
    forall a b. a -> b -> b
    `seq` Int -> Type -> Int
    go Int
    n' Type
    t
            go Int
    n Type
    _ = Int
    n

    typeToName :: Type -> Maybe Name
    typeToName :: Type -> Maybe Name
    typeToName Type
    t
      | ConT Name
    n <- Type
    t = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    n
      | Type
    ArrowT <- Type
    t = Name -> Maybe Name
    forall a. a -> Maybe a
    Just ''(->)
      | Type
    ListT  <- Type
    t = Name -> Maybe Name
    forall a. a -> Maybe a
    Just ''[]
      | TupleT Int
    n <- Type
    t = Name -> Maybe Name
    forall a. a -> Maybe a
    Just (Name -> Maybe Name) -> Name -> Maybe Name
    forall a b. (a -> b) -> a -> b
    $ Int -> Name
    tupleTypeName Int
    n
      | ForallT [TyVarBndr Specificity]
    _ Cxt
    _ Type
    t' <- Type
    t = Type -> Maybe Name
    typeToName Type
    t'
      | Bool
    otherwise = Maybe Name
    forall a. Maybe a
    Nothing

    -- | Randomly useful.
    nameSpaceOf :: Name -> Maybe NameSpace
    nameSpaceOf :: Name -> Maybe NameSpace
    nameSpaceOf (Name OccName
    _ (NameG NameSpace
    ns PkgName
    _ ModName
    _)) = NameSpace -> Maybe NameSpace
    forall a. a -> Maybe a
    Just NameSpace
    ns
    nameSpaceOf Name
    _                       = Maybe NameSpace
    forall a. Maybe a
    Nothing

    conName :: Con -> Name
    conName :: Con -> Name
    conName (RecC Name
    n [VarStrictType]
    _)        = Name
    n
    conName (NormalC Name
    n [StrictType]
    _)     = Name
    n
    conName (InfixC StrictType
    _ Name
    n StrictType
    _)    = Name
    n
    conName (ForallC [TyVarBndr Specificity]
    _ Cxt
    _ Con
    con) = Con -> Name
    conName Con
    con
    conName Con
    c                 = String -> Name
    forall a. HasCallStack => String -> a
    error (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ String
    "conName: TODO for" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Con -> String
    forall a. Show a => a -> String
    show Con
    c
    -- TODO
                -- (GadtC _ _ _)
                -- (RecGadtC _ _ _)

    recCName :: Con -> Maybe Name
    recCName :: Con -> Maybe Name
    recCName (RecC Name
    n [VarStrictType]
    _) = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    n
    recCName Con
    _          = Maybe Name
    forall a. Maybe a
    Nothing

    fromDataConI :: Info -> Q (Maybe Exp)
    fromDataConI :: Info -> Q (Maybe Exp)
    fromDataConI (DataConI Name
    dConN Type
    ty Name
    _tyConN) =
      let n :: Int
    n = Type -> Int
    arityT Type
    ty
      in Int -> Q Name -> Q [Name]
    forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
    replicateM Int
    n (String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "a")
          Q [Name] -> ([Name] -> Q (Maybe Exp)) -> Q (Maybe Exp)
    forall a b. Q a -> (a -> Q b) -> Q b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \[Name]
    ns -> Maybe Exp -> Q (Maybe Exp)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just ([Pat] -> Exp -> Exp
    LamE
                        [Name -> [Pat] -> Pat
    Compat.conP Name
    dConN ((Name -> Pat) -> [Name] -> [Pat]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Name -> Pat
    VarP [Name]
    ns)]
    #if MIN_VERSION_template_haskell(2,16,0)
                        ([Maybe Exp] -> Exp
    TupE ([Maybe Exp] -> Exp) -> [Maybe Exp] -> Exp
    forall a b. (a -> b) -> a -> b
    $ (Name -> Maybe Exp) -> [Name] -> [Maybe Exp]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (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]
    ns)
    #else
                        (TupE $ fmap VarE ns)
    #endif
                        ))
    fromDataConI Info
    _ = Maybe Exp -> Q (Maybe Exp)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe Exp
    forall a. Maybe a
    Nothing

    fromTyConI :: Info -> Maybe Dec
    fromTyConI :: Info -> Maybe Dec
    fromTyConI (TyConI Dec
    dec) = Dec -> Maybe Dec
    forall a. a -> Maybe a
    Just Dec
    dec
    fromTyConI Info
    _            = Maybe Dec
    forall a. Maybe a
    Nothing

    mkFunD :: Name -> [Pat] -> Exp -> Dec
    mkFunD :: Name -> [Pat] -> Exp -> Dec
    mkFunD Name
    f [Pat]
    xs Exp
    e = Name -> [Clause] -> Dec
    FunD Name
    f [[Pat] -> Body -> [Dec] -> Clause
    Clause [Pat]
    xs (Exp -> Body
    NormalB Exp
    e) []]

    mkClauseQ :: [PatQ] -> ExpQ -> ClauseQ
    mkClauseQ :: [PatQ] -> ExpQ -> ClauseQ
    mkClauseQ [PatQ]
    ps ExpQ
    e = [PatQ] -> Q Body -> [DecQ] -> ClauseQ
    forall (m :: * -> *).
    Quote m =>
    [m Pat] -> m Body -> [m Dec] -> m Clause
    clause [PatQ]
    ps (ExpQ -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB ExpQ
    e) []

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

    -- | The strategy for producing QuasiQuoters which
    --  this datatype aims to facilitate is as follows.
    --  Given a collection of datatypes which make up
    --  the to-be-quasiquoted languages AST, make each
    --  type in this collection an instance of at least
    --  @Show@ and @Lift@. Now, assuming @parsePat@ and
    --  @parseExp@, both of type @String -> Q a@ (where @a@
    --  is the top level type of the AST), are the pair of
    --  functions you wish to use for parsing in pattern and
    --  expression context respectively, put them inside
    --  a @Quoter@ datatype and pass this to quasify.
    {-
    data Quoter a = Quoter
      { expQ :: (Lift a) => String -> Q a
      , patQ :: (Show a) => String -> Q a }

    quasify :: (Show a, Lift a) => Quoter a -> QuasiQuoter
    quasify q = QuasiQuoter
                  (toExpQ (expQ q))
                  (toPatQ (patQ q))
                  -}

    toExpQ :: (Lift a) => (String -> Q a) -> (String -> ExpQ)
    toExpQ :: forall a. Lift a => (String -> Q a) -> String -> ExpQ
    toExpQ String -> Q a
    parseQ = (a -> ExpQ
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => a -> m Exp
    lift (a -> ExpQ) -> Q a -> ExpQ
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<<) (Q a -> ExpQ) -> (String -> Q a) -> String -> ExpQ
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Q a
    parseQ

    toPatQ :: (Show a) => (String -> Q a) -> (String -> PatQ)
    toPatQ :: forall a. Show a => (String -> Q a) -> String -> PatQ
    toPatQ String -> Q a
    parseQ = (a -> PatQ
    forall a. Show a => a -> PatQ
    showToPatQ (a -> PatQ) -> Q a -> PatQ
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<<) (Q a -> PatQ) -> (String -> Q a) -> String -> PatQ
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Q a
    parseQ

    showToPatQ :: (Show a) => a -> PatQ
    showToPatQ :: forall a. Show a => a -> PatQ
    showToPatQ = (String -> PatQ) -> (Pat -> PatQ) -> Either String Pat -> PatQ
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either String -> PatQ
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail Pat -> PatQ
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Either String Pat -> PatQ)
    -> (a -> Either String Pat) -> a -> PatQ
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Either String Pat
    parsePat (String -> Either String Pat)
    -> (a -> String) -> a -> Either String Pat
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> String
    forall a. Show a => a -> String
    show

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

    eitherQ :: (e -> String) -> Either e a -> Q a
    eitherQ :: forall e a. (e -> String) -> Either e a -> Q a
    eitherQ e -> String
    toStr = (e -> Q a) -> (a -> Q a) -> Either e a -> Q a
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either (String -> Q a
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q a) -> (e -> String) -> e -> Q a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . e -> String
    toStr) a -> Q a
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return

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

    normalizeT :: (Data a) => a -> a
    normalizeT :: forall a. Data a => a -> a
    normalizeT = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
    everywhere ((Type -> Type) -> a -> a
    forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
    mkT Type -> Type
    go)
      where go :: Type -> Type
            go :: Type -> Type
    go (ConT Name
    n) | Name
    n Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''[] = Type
    ListT
            go (AppT (TupleT Int
    1) Type
    t) = Type
    t
            go (ConT Name
    n)
              | Just Int
    m <- (Name -> Bool) -> [Name] -> Maybe Int
    forall a. (a -> Bool) -> [a] -> Maybe Int
    findIndex (Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    n) [Name]
    tupleNames = Int -> Type
    TupleT (Int
    m Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    2)
             where
              tupleNames :: [Name]
    tupleNames = (Int -> Name) -> [Int] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map Int -> Name
    tupleTypeName [Int
    2 .. Int
    64]
            go Type
    t = Type
    t

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