{-# 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
    [Dec]
decs <- DecsQ
decsq
    let labeledDecs :: [(Name, Dec)]
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
    [StmtQ] -> ExpQ
doE ([StmtQ] -> ExpQ) -> [StmtQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$
        ((Name, Dec) -> StmtQ) -> [(Name, Dec)] -> [StmtQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Dec) -> StmtQ
toStmt [(Name, Dec)]
labeledDecs [StmtQ] -> [StmtQ] -> [StmtQ]
forall a. [a] -> [a] -> [a]
++
        [ ExpQ -> StmtQ
noBindS [e| return $ concat $(listE (map (varE . fst) labeledDecs)) |] ]
  where
    -- FIXME: handle overlap info in template-haskell > 2.11.0
    toStmt :: (Name, Dec) -> StmtQ
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, []) ->
            PatQ -> ExpQ -> StmtQ
bindS (Name -> PatQ
varP Name
varName)
                  [e| runDeriver $(proxyE (return (tyVarsToAny cls)))
                                 preds
                                 cls |]
        Just (Cxt
preds, Type
ty, [Dec]
decs) ->
            PatQ -> ExpQ -> StmtQ
bindS (Name -> PatQ
varP Name
varName)
                  [e| runInstantiator $(proxyE (return (tyVarsToAny ty)))
                                      preds
                                      ty
                                      decs |]
        Maybe (Cxt, Type, [Dec])
_ -> String -> StmtQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StmtQ) -> String -> StmtQ
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 :: 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 :: Name -> a -> Q a
dequalifyMethods Name
className a
x = do
      Info
info <- Name -> Q Info
reify Name
className
      case Info
info of
          ClassI (ClassD Cxt
_ Name
_ [TyVarBndr]
_ [FunDep]
_ [Dec]
decls) [Dec]
_ ->
              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 (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 :: [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 (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
-}