    {-# LANGUAGE ConstraintKinds #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE KindSignatures #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE ViewPatterns #-}

    -- | This module implements a system for registering and using typeclass
    -- derivers and instantiators. This allows you to derive instances for
    -- typeclasses beyond GHC's ability to generate instances in @deriving@
    -- clauses.
    --
    -- For example, "TH.Derive.Storable" defines a 'Deriver' for 'Storable'.
    -- This allows us to use 'derive' to generate an instance for Storable:
    --
    -- @
    --     data X = X Int Float
    --
    --     $($(derive [d|
    --         instance Deriving (Storable X)
    --         |]))
    -- @
    --
    -- In particular, note the use of double splicing, @$($(derive [d| ...
    -- |]))@. The inner @$(derive [d| ... |])@ expression generates code
    -- which invokes the 'runDeriver' method with appropriate arguments. The
    -- outer @$( ... $)@ then runs that code in order to generate the
    -- resulting instances. This is how it does dispatch at compile time.
    --
    -- There are a number of advantages of re-using instance syntax in this
    -- way:
    --
    -- * It allows the user to specify constraints. Similarly to GHC's need
    -- for standalone deriving, it is sometimes very difficult for TH to
    -- figure out appropriate superclass constraints.
    --
    -- * The instance gets thoroughly checked by GHC (syntax, kind, and type
    -- checking). This means that you get reasonably nice error messages
    -- when you misuse these.
    --
    -- * It allows the user to specify methods. With 'Instantiator's, the
    -- user can provide values which can be used in the definition of the
    -- generated instance. This is a bit like having
    -- <https://ghc.haskell.org/trac/ghc/wiki/InstanceTemplates Instance Templates>.
    -- We don't have pretty ways of writing these quite yet, but
    -- I have worked on something
    -- <https://github.com/mgsloan/instance-templates similar in the past>.
    --
    -- * Using compile-time dispatch allows for concise specification of a
    -- multiple of instances you'd like derived.
    --
    -- * In the case of use of a 'Deriver's, the user doesn't need to know
    -- about anything but 'derive' and the name of the class they want. (and
    -- the 'Deriver' instance must be in scope one way or another)
    module TH.Derive
        ( derive
        , Deriving
        , Deriver(..)
        , Instantiator(..)
        , dequalifyMethods
        ) where

    import Data.Data
    import Data.Generics
    import Language.Haskell.TH
    import Language.Haskell.TH.Instances ()
    import TH.Utilities
    import TH.Derive.Internal
    import TH.Derive.Storable ()
    import GHC.Exts (Any)

    --TODO: support deriving on constraint kinds, for concision!

    -- | This is the primary function for users of "TH.Derive". See the
    -- module documentation for usage info.
    derive :: DecsQ -> ExpQ
    derive :: DecsQ -> ExpQ
    derive DecsQ
    decsq = do
        decs <- DecsQ
    decsq
        let labeledDecs = [Name] -> [Dec] -> [(Name, Dec)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip ((Int -> Name) -> [Int] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map (String -> Name
    mkName (String -> Name) -> (Int -> String) -> Int -> Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String
    "x" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++) (String -> String) -> (Int -> String) -> Int -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> String
    forall a. Show a => a -> String
    show) [(Int
    0::Int)..]) [Dec]
    decs
        doE $
            map toStmt labeledDecs ++
            [ noBindS [e| return $ concat $(listE (map (varE . fst) labeledDecs)) |] ]
      where
        -- FIXME: handle overlap info in template-haskell > 2.11.0
        toStmt :: (Name, Dec) -> Q Stmt
    toStmt (Name
    varName, Dec
    dec) = case Dec -> Maybe (Cxt, Type, [Dec])
    fromPlainInstanceD Dec
    dec of
            Just (Cxt
    preds, AppT (ConT ((Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''Deriving) -> Bool
    True)) Type
    cls, []) ->
                Q Pat -> ExpQ -> Q Stmt
    forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
    bindS (Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    varName)
                      [e| runDeriver $(TypeQ -> ExpQ
    proxyE (Type -> TypeQ
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type -> Type
    forall a. Data a => a -> a
    tyVarsToAny Type
    cls)))
                                     preds
                                     cls |]
            Just (Cxt
    preds, Type
    ty, [Dec]
    decs) ->
                Q Pat -> ExpQ -> Q Stmt
    forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
    bindS (Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    varName)
                      [e| runInstantiator $(TypeQ -> ExpQ
    proxyE (Type -> TypeQ
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type -> Type
    forall a. Data a => a -> a
    tyVarsToAny Type
    ty)))
                                          preds
                                          ty
                                          decs |]
            Maybe (Cxt, Type, [Dec])
    _ -> String -> Q Stmt
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q Stmt) -> String -> Q Stmt
    forall a b. (a -> b) -> a -> b
    $
                String
    "Expected deriver or instantiator, instead got:\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                Dec -> String
    forall a. Show a => a -> String
    show Dec
    dec

    -- | Turn type variables into uses of 'Any'.
    --
    -- The purpose of this is to avoid errors such as described in
    -- https://github.com/fpco/store/issues/140 .  The problem is that
    -- older GHC versions (<= 7.10) have a bug where they expect type
    -- variables in expressions to be in scope.
    tyVarsToAny :: Data a => a -> a
    tyVarsToAny :: forall a. Data a => a -> a
    tyVarsToAny = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
    everywhere (a -> a
    forall a. a -> a
    id (a -> a) -> (Type -> Type) -> a -> a
    forall a b.
    (Typeable a, Typeable b) =>
    (a -> a) -> (b -> b) -> a -> a
    `extT` Type -> Type
    modifyType)
      where
        modifyType :: Type -> Type
    modifyType (VarT Name
    _) = Name -> Type
    ConT ''Any
        modifyType Type
    ty = Type
    ty

    -- | Useful function for defining 'Instantiator' instances. It uses
    -- 'Data' to generically replace references to the methods with plain
    -- 'Name's. This is handy when you are putting the definitions passed to
    -- the instantiator in a where clause. It is also useful so that you can
    -- reference the class methods from AST quotes involved in the
    -- definition of the instantiator.
    dequalifyMethods :: Data a => Name -> a -> Q a
    dequalifyMethods :: forall a. Data a => Name -> a -> Q a
    dequalifyMethods Name
    className a
    x = do
          info <- Name -> Q Info
    reify Name
    className
          case info of
              ClassI (ClassD Cxt
    _ Name
    _ [TyVarBndr BndrVis]
    _ [FunDep]
    _ [Dec]
    decls) [Dec]
    _ ->
                  a -> Q a
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Name] -> a -> a
    forall b. Data b => [Name] -> b -> b
    go [Name
    n | SigD Name
    n Type
    _ <- [Dec]
    decls] a
    x)
              Info
    _ -> String -> Q a
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q a) -> String -> Q a
    forall a b. (a -> b) -> a -> b
    $ String
    "dequalifyMethods expected class, but got:\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Info -> String
    forall a. Ppr a => a -> String
    pprint Info
    info
        where
          go :: Data b => [Name] -> b -> b
          go :: forall b. Data b => [Name] -> b -> b
    go [Name]
    names = (forall a. Data a => a -> a) -> b -> b
    forall a. Data a => (forall a. Data a => a -> a) -> a -> a
    gmapT ([Name] -> b -> b
    forall b. Data b => [Name] -> b -> b
    go [Name]
    names) (b -> b) -> (String -> String) -> b -> b
    forall a b.
    (Typeable a, Typeable b) =>
    (a -> a) -> (b -> b) -> a -> a
    `extT` (String -> String
    forall a. a -> a
    id :: String -> String) (b -> b) -> (Name -> Name) -> b -> b
    forall a b.
    (Typeable a, Typeable b) =>
    (a -> a) -> (b -> b) -> a -> a
    `extT`
              (\Name
    n -> if 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]
    names then Name -> Name
    dequalify Name
    n else Name
    n)

    {-
        -- Code originally from 'deriver'
        -- TODO: warnings / errors for invalid derivers?
        ClassI _ insts <- reify ''Deriver
        let derivers = mapMaybe deriverInfo insts

    deriverInfo :: InstanceDec -> Maybe (Name, Name, Type)
    deriverInfo (InstanceD _ (AppT (AppT (ConT ''Deriving) (ConT deriver)) cls)) =
         case unAppsT cls of
             (ConT clsName, _) -> Just (deriver, clsName, cls)
             _ -> Nothing
    deriverInfo _ = Nothing
    -}