{-# LANGUAGE
  BlockArguments,
  CPP,
  LambdaCase,
  MultiWayIf,
  NamedFieldPuns,
  PatternSynonyms,
  RankNTypes,
  ScopedTypeVariables,
  TemplateHaskell,
  ViewPatterns #-}

-- | TH for dictionary representation generation. This module is internal and

-- provides no guarantees about stability and safety of its interface.

module FCI.Internal.TH (
    -- * Main API

    mkDict
  , setDictOptions
  , DictOptions(methodName,superclassName,typeName,constructorName,autoDoc)
  , dictOptions
  , instanceDict
  , instanceDict_
  , instanceDictM
  , TH.Overlap(Overlappable, Overlapping, Overlaps, Incoherent)
    -- * Synonyms

  , ClassName
  , MethodName
  , FieldName
  , TypeName
  , ConstrName
  ) where

import Language.Haskell.TH.Ppr (pprint)
import Language.Haskell.TH.Syntax as TH

import Control.Monad (when)
import Control.Monad.Trans.State
import           Data.Char           (isAlpha)
import Data.Data
import qualified Data.Kind as K
import           Data.List           (foldl1', stripPrefix)
import qualified Data.Map.Strict as M
import           Data.Maybe          (fromMaybe, mapMaybe)

import FCI.Internal (Dict)

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

-- | Declare the dictionary type associated with a given class.

-- The generated type is a record of class members with the following format

-- by default (it can be customized using 'setDictOptions'):

--

-- * The type of the record is `Dict` prepended to the name of the class.

--

-- * The name of the constructor is the name of the class.

--

-- * Superclass constraints are transformed into fields containing their

--   dictionaries. The names of those fields are generated this way:

--

--     * Alphabetic names (/e.g./, 'Show', 'Applicative') are prefixed with @_@

--     * Operators (/e.g./, @(~)@) are prefixed with @/@

--     * Tuples are converted into @_Tuple2@, @_Tuple3@, etc.

--     * Multiple occurrences of the same superclass are suffixed with an index

--       starting from 1, or with an increasing number of @|@s if its name is

--       an operator.

--

-- * Methods get their own fields; their names are the names of methods

--   prefixed with @_@ for alphabetic method names, or @|@ for operators.

--

-- This behavior can be configured using 'FCI.TH.setDictOptions' from "FCI.TH".

mkDict :: Name -> Q [Dec]
mkDict :: Name -> Q [InstanceDec]
mkDict Name
cname = do
  DictOptions
opts <- Q DictOptions
getDictOptions
  DictOptions -> Name -> Q [InstanceDec]
mkDictWith DictOptions
opts Name
cname

type ClassName = String
type MethodName = String
type FieldName = String
type TypeName = String
type ConstrName = String

-- | Options to configure 'mkDict'. The constructor is hidden so you have to use

-- record update with 'dictOptions'.

--

-- === Example

--

-- @

-- 'setDictOptions' 'dictOptions' { 'autoDoc' = False }

-- @

data DictOptions = DictOptions
  { -- | t'DictOptions' setting to generate a field name from the

    -- name of the class and one of its methods.

    --

    -- By default, prepend @"_"@ to alphabetic identifiers, and prepend @"|"@

    -- to operators.

    DictOptions -> ClassName -> ClassName -> ClassName
methodName :: ClassName -> MethodName -> FieldName

    -- | t'DictOptions' setting to generate a field name from the name

    -- of the class and one of its superclasses. The @Int@ is a counter of duplicate

    -- superclasses, starts at 0.

    --

    -- By default, prepend @\"_\"@ to alphabetic identifiers, and prepend @\"/\"@

    -- to operators.

  , DictOptions -> ClassName -> ClassName -> Int -> ClassName
superclassName :: ClassName -> ClassName -> Int -> FieldName

    -- | t'DictOptions' setting to generate a type name from the name of the class.

    --

    -- By default, prepend @\"Dict\"@ to alphabetic identifiers, and prepend

    -- @\".\"@ to operators.

  , DictOptions -> ClassName -> ClassName
typeName :: ClassName -> TypeName

    -- | t'DictOptions' setting to generate a constructor name from the name of the class.

    --

    -- By default, keep alphabetic identifiers unchanged, and prepend

    -- @\":\"@ to operators.

  , DictOptions -> ClassName -> ClassName
constructorName :: ClassName -> ConstrName

    -- | t'DictOptions' setting to automatically generate a haddock comment.

    -- The comment will say "Dictionary type for @CLASS@".

    --

    -- @True@ by default.

  , DictOptions -> Bool
autoDoc :: Bool
  }

-- | Set options for subsequent invocations of 'mkDict'.

-- This setting only affects the current module.

--

-- Returns the empty list so it can be used as a top-level slice.

setDictOptions :: DictOptions -> Q [a]
setDictOptions :: forall a. DictOptions -> Q [a]
setDictOptions DictOptions
opts = DictOptions -> Q ()
forall a. Typeable a => a -> Q ()
putQ DictOptions
opts Q () -> Q [a] -> Q [a]
forall a b. Q a -> Q b -> Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [a] -> Q [a]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

getDictOptions :: Q DictOptions
getDictOptions :: Q DictOptions
getDictOptions = DictOptions -> Maybe DictOptions -> DictOptions
forall a. a -> Maybe a -> a
fromMaybe DictOptions
dictOptions (Maybe DictOptions -> DictOptions)
-> Q (Maybe DictOptions) -> Q DictOptions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q (Maybe DictOptions)
forall a. Typeable a => Q (Maybe a)
getQ

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

-- | Creates name of field holding method implementation from method name. Name

-- is generated this way:

--

-- * Prefix names ('show', 'pure') are prefixed with @_@

-- * Operators (('<*>'), ('>>=')) are prefixed with @|@

defaultMethodName :: MethodName -> MethodName
defaultMethodName :: ClassName -> ClassName
defaultMethodName name :: ClassName
name@(Char
c : ClassName
_)
  | Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' = ClassName
"_" ClassName -> ClassName -> ClassName
forall a. [a] -> [a] -> [a]
++ ClassName
name
  | Bool
otherwise = ClassName
"|" ClassName -> ClassName -> ClassName
forall a. [a] -> [a] -> [a]
++ ClassName
name
defaultMethodName [] = ClassName -> ClassName
forall a. HasCallStack => ClassName -> a
error ClassName
"empty name!"

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

-- | Creates name of field holding superclass instance from name of class. Name

-- is generated this way:

--

-- * Prefix names ('Show', 'Applicative') are prefixed with @_@

-- * Operators (@(~)@) are prefixed with @/@

-- * Tuples are converted into prefix names "_Tuple"

--

-- If there are multiple constraints with same name:

--

-- * Prefix names and names of tuples get numeric suffixes in order

-- * Operators are suffixed with increasing number of @|@

defaultSuperclassName :: ClassName -> Int -> MethodName
defaultSuperclassName :: ClassName -> Int -> ClassName
defaultSuperclassName name :: ClassName
name@(Char
c:ClassName
_) Int
count
  | Char -> Bool
isAlpha  Char
c = ClassName
"_" ClassName -> ClassName -> ClassName
forall a. [a] -> [a] -> [a]
++ ClassName
name     ClassName -> ClassName -> ClassName
forall a. [a] -> [a] -> [a]
++ ClassName
index
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'('   =        ClassName
"_Tuple" ClassName -> ClassName -> ClassName
forall a. [a] -> [a] -> [a]
++ ClassName
index
  | Bool
otherwise  = ClassName
"/" ClassName -> ClassName -> ClassName
forall a. [a] -> [a] -> [a]
++ ClassName
name     ClassName -> ClassName -> ClassName
forall a. [a] -> [a] -> [a]
++ Int -> Char -> ClassName
forall a. Int -> a -> [a]
replicate Int
count Char
'|'
  where
    index :: ClassName
index = if Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then ClassName
"" else Int -> ClassName
forall a. Show a => a -> ClassName
show Int
count
defaultSuperclassName ClassName
_ Int
_ = ClassName -> ClassName
forall a. HasCallStack => ClassName -> a
error ClassName
"emtpy name!"

defaultTypeName :: ClassName -> TypeName
defaultTypeName :: ClassName -> ClassName
defaultTypeName name :: ClassName
name@(Char
c : ClassName
_)
  | Char -> Bool
isAlpha Char
c = ClassName
"Dict" ClassName -> ClassName -> ClassName
forall a. [a] -> [a] -> [a]
++ ClassName
name
  | Bool
otherwise = ClassName
"." ClassName -> ClassName -> ClassName
forall a. [a] -> [a] -> [a]
++ ClassName
name
defaultTypeName [] = ClassName -> ClassName
forall a. HasCallStack => ClassName -> a
error ClassName
"empty name!"

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

-- | Creates name of dictionary representation data constructor from name of

-- class. Name is generated this way:

--

-- * Prefix names ('Show', 'Applicative') are kept as-is

-- * Operators (@(~)@) are prefixed with colon @:@

defaultConstructorName :: ClassName -> ConstrName
defaultConstructorName :: ClassName -> ClassName
defaultConstructorName name :: ClassName
name@(Char
c : ClassName
_)
  | Char -> Bool
isAlpha Char
c = ClassName
name
  | Bool
otherwise = ClassName
":" ClassName -> ClassName -> ClassName
forall a. [a] -> [a] -> [a]
++ ClassName
name
defaultConstructorName [] = ClassName -> ClassName
forall a. HasCallStack => ClassName -> a
error ClassName
"empty name!"

-- | Default t'DictOptions'. To be modified with record updates.

--

-- @

-- 'dictOptions'

--   { 'methodName' = _

--   , 'superclassName' = _

--   , 'typeName' = _

--   , 'constructorName' = _

--   , 'autoDoc' = _

--   }

-- @

dictOptions :: DictOptions
dictOptions :: DictOptions
dictOptions = DictOptions
  { methodName :: ClassName -> ClassName -> ClassName
methodName = \ClassName
_ -> ClassName -> ClassName
defaultMethodName
  , superclassName :: ClassName -> ClassName -> Int -> ClassName
superclassName = \ClassName
_ -> ClassName -> Int -> ClassName
defaultSuperclassName
  , typeName :: ClassName -> ClassName
typeName = ClassName -> ClassName
defaultTypeName
  , constructorName :: ClassName -> ClassName
constructorName = ClassName -> ClassName
defaultConstructorName
  , autoDoc :: Bool
autoDoc = Bool
True
  }

mapName :: (String -> String) -> Name -> Name
mapName :: (ClassName -> ClassName) -> Name -> Name
mapName ClassName -> ClassName
f Name
name = ClassName -> Name
mkName (ClassName -> ClassName
f (Name -> ClassName
nameBase Name
name))

methodName' :: DictOptions -> Name -> Name -> Name
methodName' :: DictOptions -> Name -> Name -> Name
methodName' DictOptions
opts Name
cname = (ClassName -> ClassName) -> Name -> Name
mapName (DictOptions -> ClassName -> ClassName -> ClassName
methodName DictOptions
opts (Name -> ClassName
nameBase Name
cname))

superclassName' :: DictOptions -> Name -> Name -> Int -> Name
superclassName' :: DictOptions -> Name -> Name -> Int -> Name
superclassName' DictOptions
opts Name
cname Name
sname Int
i = ClassName -> Name
mkName (DictOptions -> ClassName -> ClassName -> Int -> ClassName
superclassName DictOptions
opts (Name -> ClassName
nameBase Name
cname) (Name -> ClassName
nameBase Name
sname) Int
i)

typeName' :: DictOptions -> Name -> Name
typeName' :: DictOptions -> Name -> Name
typeName' DictOptions
opts = (ClassName -> ClassName) -> Name -> Name
mapName (DictOptions -> ClassName -> ClassName
typeName DictOptions
opts)

constructorName' :: DictOptions -> Name -> Name
constructorName' :: DictOptions -> Name -> Name
constructorName' DictOptions
opts = (ClassName -> ClassName) -> Name -> Name
mapName (DictOptions -> ClassName -> ClassName
constructorName DictOptions
opts)

mkDictWith :: DictOptions -> Name -> Q [Dec]
mkDictWith :: DictOptions -> Name -> Q [InstanceDec]
mkDictWith DictOptions
opts Name
name = do
  ClassDictInfo
info <- DictOptions -> Name -> Q ClassDictInfo
getClassDictInfo DictOptions
opts Name
name
#if MIN_VERSION_template_haskell(2,18,0)
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DictOptions -> Bool
autoDoc DictOptions
opts) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ Q () -> Q ()
addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
    DocLoc -> ClassName -> Q ()
putDoc (Name -> DocLoc
DeclDoc (DictOptions -> Name -> Name
typeName' DictOptions
opts Name
name)) (ClassName
"Dictionary type for t'" ClassName -> ClassName -> ClassName
forall a. [a] -> [a] -> [a]
++ Name -> ClassName
forall a. Ppr a => a -> ClassName
pprint Name
name ClassName -> ClassName -> ClassName
forall a. [a] -> [a] -> [a]
++ ClassName
"'")
#endif
  [InstanceDec] -> Q [InstanceDec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DictOptions -> ClassDictInfo -> [InstanceDec]
dictInst DictOptions
opts ClassDictInfo
info)

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

-- | Constructs info about class dictionary representation being created.

getClassDictInfo :: DictOptions -> Name -> Q ClassDictInfo
getClassDictInfo :: DictOptions -> Name -> Q ClassDictInfo
getClassDictInfo DictOptions
opts Name
className = Name -> Q Info
reify Name
className Q Info -> (Info -> Q ClassDictInfo) -> Q ClassDictInfo
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  ClassI (ClassD Cxt
constraints Name
_ [TyVarBndr BndrVis]
args [FunDep]
_ [InstanceDec]
methods) [InstanceDec]
_ -> do
    let dictConName :: Name
dictConName = DictOptions -> Name -> Name
constructorName' DictOptions
opts Name
className
    ClassDictInfo -> Q ClassDictInfo
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CDI{
        Name
className :: Name
className :: Name
className
      , dictTyArgs :: [TyVarBndr BndrVis]
dictTyArgs  = [TyVarBndr BndrVis]
args
      , Name
dictConName :: Name
dictConName :: Name
dictConName
      , dictFields :: [ClassDictField]
dictFields  = DictOptions -> Name -> Cxt -> [ClassDictField]
superFieldsFromCxt DictOptions
opts Name
className Cxt
constraints
                   [ClassDictField] -> [ClassDictField] -> [ClassDictField]
forall a. [a] -> [a] -> [a]
++ (InstanceDec -> Maybe ClassDictField)
-> [InstanceDec] -> [ClassDictField]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (DictOptions -> Name -> InstanceDec -> Maybe ClassDictField
methodFieldFromDec DictOptions
opts Name
className) [InstanceDec]
methods
      }
  Info
_ -> ClassName -> Q ClassDictInfo
forall a. ClassName -> Q a
forall (m :: * -> *) a. MonadFail m => ClassName -> m a
fail (ClassName -> Q ClassDictInfo) -> ClassName -> Q ClassDictInfo
forall a b. (a -> b) -> a -> b
$ Char
'\'' Char -> ClassName -> ClassName
forall a. a -> [a] -> [a]
: Name -> ClassName
nameBase Name
className ClassName -> ClassName -> ClassName
forall a. [a] -> [a] -> [a]
++ ClassName
"' is not a class"

#if MIN_VERSION_template_haskell(2,21,0)
type TVB = TyVarBndr BndrVis
#elif MIN_VERSION_template_haskell(2,17,0)
type TVB = TyVarBndr ()
#else
type TVB = TyVarBndr
#endif

appCon :: Name -> [TVB] -> Type
appCon :: Name -> [TyVarBndr BndrVis] -> Pred
appCon Name
cname [TyVarBndr BndrVis]
args = (Pred -> Pred -> Pred) -> Cxt -> Pred
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' Pred -> Pred -> Pred
AppT (Cxt -> Pred) -> Cxt -> Pred
forall a b. (a -> b) -> a -> b
$ Name -> Pred
ConT Name
cname Pred -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: (TyVarBndr BndrVis -> Pred) -> [TyVarBndr BndrVis] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> Pred
forall a. TyVarBndr a -> Pred
bndrToType [TyVarBndr BndrVis]
args


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

-- | Creates class dictionary representation fields from constraints that carry

-- runtime proof, preserving order.

superFieldsFromCxt :: DictOptions -> Name -> [Pred] -> [ClassDictField]
superFieldsFromCxt :: DictOptions -> Name -> Cxt -> [ClassDictField]
superFieldsFromCxt DictOptions
opts Name
cname Cxt
constraints = (State (Map Name Int) [ClassDictField]
-> Map Name Int -> [ClassDictField]
forall s a. State s a -> s -> a
`evalState` Map Name Int
forall k a. Map k a
M.empty) do
  [StateT (Map Name Int) Identity ClassDictField]
-> State (Map Name Int) [ClassDictField]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([StateT (Map Name Int) Identity ClassDictField]
 -> State (Map Name Int) [ClassDictField])
-> [StateT (Map Name Int) Identity ClassDictField]
-> State (Map Name Int) [ClassDictField]
forall a b. (a -> b) -> a -> b
$ (Pred -> Maybe (StateT (Map Name Int) Identity ClassDictField))
-> Cxt -> [StateT (Map Name Int) Identity ClassDictField]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Name -> StateT (Map Name Int) Identity ClassDictField)
-> Maybe Name
-> Maybe (StateT (Map Name Int) Identity ClassDictField)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Name -> StateT (Map Name Int) Identity ClassDictField)
 -> Maybe Name
 -> Maybe (StateT (Map Name Int) Identity ClassDictField))
-> (Pred -> Name -> StateT (Map Name Int) Identity ClassDictField)
-> Pred
-> Maybe Name
-> Maybe (StateT (Map Name Int) Identity ClassDictField)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pred -> Name -> StateT (Map Name Int) Identity ClassDictField
forall {m :: * -> *}.
Monad m =>
Pred -> Name -> StateT (Map Name Int) m ClassDictField
mkSuperField (Pred
 -> Maybe Name
 -> Maybe (StateT (Map Name Int) Identity ClassDictField))
-> (Pred -> Maybe Name)
-> Pred
-> Maybe (StateT (Map Name Int) Identity ClassDictField)
forall a b. (Pred -> a -> b) -> (Pred -> a) -> Pred -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pred -> Maybe Name
appHeadName) Cxt
constraints
 where
  mkSuperField :: Pred -> Name -> StateT (Map Name Int) m ClassDictField
mkSuperField Pred
c Name
n = do
    Int
count <- Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 Int -> Int
forall a. a -> a
id (Maybe Int -> Int)
-> (Map Name Int -> Maybe Int) -> Map Name Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Map Name Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n (Map Name Int -> Int)
-> StateT (Map Name Int) m (Map Name Int)
-> StateT (Map Name Int) m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (Map Name Int) m (Map Name Int)
forall (m :: * -> *) s. Monad m => StateT s m s
get
    (Map Name Int -> Map Name Int) -> StateT (Map Name Int) m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((Map Name Int -> Map Name Int) -> StateT (Map Name Int) m ())
-> (Map Name Int -> Map Name Int) -> StateT (Map Name Int) m ()
forall a b. (a -> b) -> a -> b
$ (Maybe Int -> Maybe Int) -> Name -> Map Name Int -> Map Name Int
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (Maybe Int -> (Int -> Maybe Int) -> Maybe Int -> Maybe Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) ((Int -> Maybe Int) -> Maybe Int -> Maybe Int)
-> (Int -> Maybe Int) -> Maybe Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Int -> Int) -> Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) Name
n
    ClassDictField -> StateT (Map Name Int) m ClassDictField
forall a. a -> StateT (Map Name Int) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CDF{
        fieldName :: Name
fieldName   = DictOptions -> Name -> Name -> Int -> Name
superclassName' DictOptions
opts Name
cname Name
n Int
count
      , fieldSource :: ClassDictFieldSource
fieldSource = ClassDictFieldSource
Superclass
      , origName :: Name
origName    = Name
n
      , origType :: Pred
origType    = Pred
c
      }

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

-- | Converts type variable binder to type.

#if MIN_VERSION_template_haskell(2,17,0)
bndrToType :: TyVarBndr a -> Type
bndrToType :: forall a. TyVarBndr a -> Pred
bndrToType = \case
  PlainTV Name
n a
_    -> Name -> Pred
VarT Name
n
  KindedTV Name
n a
_ Pred
k -> Name -> Pred
VarT Name
n Pred -> Pred -> Pred
`SigT` Pred
k
#else
bndrToType :: TyVarBndr -> Type
bndrToType = \case
  PlainTV n    -> VarT n
  KindedTV n k -> VarT n `SigT` k
#endif

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

-- | Extracts name of head of type application or returns 'Nothing'.

appHeadName :: Type -> Maybe Name
appHeadName :: Pred -> Maybe Name
appHeadName = \case
  ForallT [TyVarBndr Specificity]
_ Cxt
_ Pred
t      -> Pred -> Maybe Name
appHeadName Pred
t
  AppT Pred
t Pred
_           -> Pred -> Maybe Name
appHeadName Pred
t
  SigT Pred
t Pred
_           -> Pred -> Maybe Name
appHeadName Pred
t
  VarT Name
n             -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
  ConT Name
n             -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
  PromotedT Name
n        -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
  InfixT Pred
_ Name
n Pred
_       -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
  UInfixT Pred
_ Name
n Pred
_      -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
  ParensT Pred
t          -> Pred -> Maybe Name
appHeadName Pred
t
  TupleT Int
i           -> ClassName -> Char -> Int -> ClassName -> Maybe Name
prod ClassName
"("  Char
',' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)  ClassName
")"
  UnboxedTupleT Int
i    -> ClassName -> Char -> Int -> ClassName -> Maybe Name
prod ClassName
"(#" Char
',' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ClassName
"#)"
  UnboxedSumT Int
i      -> ClassName -> Char -> Int -> ClassName -> Maybe Name
prod ClassName
"(#" Char
'|' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ClassName
"#)"
  Pred
ArrowT             -> Name -> Maybe Name
forall a. a -> Maybe a
Just ''(->)
  Pred
EqualityT          -> Name -> Maybe Name
forall a. a -> Maybe a
Just ''(~)
  Pred
ListT              -> Name -> Maybe Name
forall a. a -> Maybe a
Just ''[]
  PromotedTupleT Int
i   -> ClassName -> Char -> Int -> ClassName -> Maybe Name
prod ClassName
"(" Char
',' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ClassName
")"
  Pred
PromotedNilT       -> Name -> Maybe Name
forall a. a -> Maybe a
Just '[]
  Pred
PromotedConsT      -> Name -> Maybe Name
forall a. a -> Maybe a
Just '(:)
  Pred
StarT              -> Name -> Maybe Name
forall a. a -> Maybe a
Just ''K.Type
  Pred
ConstraintT        -> Name -> Maybe Name
forall a. a -> Maybe a
Just ''K.Constraint
  LitT{}             -> Maybe Name
forall a. Maybe a
Nothing
  Pred
WildCardT          -> Maybe Name
forall a. Maybe a
Nothing
#if MIN_VERSION_template_haskell(2,15,0)
  AppKindT Pred
t Pred
_       -> Pred -> Maybe Name
appHeadName Pred
t
  ImplicitParamT ClassName
_ Pred
t -> Pred -> Maybe Name
appHeadName Pred
t
#if MIN_VERSION_template_haskell(2,16,0)
  ForallVisT [TyVarBndr ()]
_ Pred
t        -> Pred -> Maybe Name
appHeadName Pred
t
#if MIN_VERSION_template_haskell(2,17,0)
  Pred
MulArrowT             -> Name -> Maybe Name
forall a. a -> Maybe a
Just ''(->)
#if MIN_VERSION_template_haskell(2,19,0)
  PromotedInfixT Pred
_ Name
n Pred
_  -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
  PromotedUInfixT Pred
_ Name
n Pred
_ -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
#endif
#endif
#endif
#endif
 where
  prod :: ClassName -> Char -> Int -> ClassName -> Maybe Name
prod ClassName
l Char
d Int
i ClassName
r  = Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ ClassName -> Name
mkName if
    | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    -> ClassName
l                  ClassName -> ClassName -> ClassName
forall a. [a] -> [a] -> [a]
++ ClassName
r
    | Bool
otherwise -> ClassName
l ClassName -> ClassName -> ClassName
forall a. [a] -> [a] -> [a]
++ Int -> Char -> ClassName
forall a. Int -> a -> [a]
replicate Int
i Char
d ClassName -> ClassName -> ClassName
forall a. [a] -> [a] -> [a]
++ ClassName
r

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

-- | Creates class dictionary representation field from class member of returns

-- 'Nothing'.

methodFieldFromDec :: DictOptions -> Name -> Dec -> Maybe ClassDictField
methodFieldFromDec :: DictOptions -> Name -> InstanceDec -> Maybe ClassDictField
methodFieldFromDec DictOptions
opts Name
cname = \case
#if MIN_VERSION_template_haskell(2,15,0)
  SigD Name
n Pred
t ->
#else
  SigD n (ForallT _ _ t) ->
#endif
    ClassDictField -> Maybe ClassDictField
forall a. a -> Maybe a
Just CDF{
      fieldName :: Name
fieldName   = DictOptions -> Name -> Name -> Name
methodName' DictOptions
opts Name
cname Name
n
    , fieldSource :: ClassDictFieldSource
fieldSource = ClassDictFieldSource
Method
    , origName :: Name
origName    = Name
n
    , origType :: Pred
origType    = Pred
t
    }
  InstanceDec
_ -> Maybe ClassDictField
forall a. Maybe a
Nothing

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

-- | Creates 'Dict' instance from info about class dictionary representation.

dictInst :: DictOptions -> ClassDictInfo -> [Dec]
dictInst :: DictOptions -> ClassDictInfo -> [InstanceDec]
dictInst DictOptions
opts ClassDictInfo
cdi = [
    InstanceDec
instDec
  , case ClassDictField -> VarBangType
classDictToRecField (ClassDictField -> VarBangType)
-> [ClassDictField] -> [VarBangType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClassDictInfo -> [ClassDictField]
dictFields ClassDictInfo
cdi of
      []      -> (Cxt
 -> Name
 -> [TyVarBndr BndrVis]
 -> Maybe Pred
 -> [Con]
 -> [DerivClause]
 -> InstanceDec)
-> [Con] -> InstanceDec
forall {a} {a} {t} {a} {t}.
([a] -> Name -> [TyVarBndr BndrVis] -> Maybe a -> t -> [a] -> t)
-> t -> t
dictDec Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Pred
-> [Con]
-> [DerivClause]
-> InstanceDec
DataD    [Name -> [BangType] -> Con
NormalC (ClassDictInfo -> Name
dictConName ClassDictInfo
cdi) []     ]
      [VarBangType
field] -> (Cxt
 -> Name
 -> [TyVarBndr BndrVis]
 -> Maybe Pred
 -> Con
 -> [DerivClause]
 -> InstanceDec)
-> Con -> InstanceDec
forall {a} {a} {t} {a} {t}.
([a] -> Name -> [TyVarBndr BndrVis] -> Maybe a -> t -> [a] -> t)
-> t -> t
dictDec Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Pred
-> Con
-> [DerivClause]
-> InstanceDec
NewtypeD (Name -> [VarBangType] -> Con
RecC    (ClassDictInfo -> Name
dictConName ClassDictInfo
cdi) [VarBangType
field])
      [VarBangType]
fields  -> (Cxt
 -> Name
 -> [TyVarBndr BndrVis]
 -> Maybe Pred
 -> [Con]
 -> [DerivClause]
 -> InstanceDec)
-> [Con] -> InstanceDec
forall {a} {a} {t} {a} {t}.
([a] -> Name -> [TyVarBndr BndrVis] -> Maybe a -> t -> [a] -> t)
-> t -> t
dictDec Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Pred
-> [Con]
-> [DerivClause]
-> InstanceDec
DataD    [Name -> [VarBangType] -> Con
RecC    (ClassDictInfo -> Name
dictConName ClassDictInfo
cdi) [VarBangType]
fields ]
  ]
 where
  dname :: Name
dname = DictOptions -> Name -> Name
typeName' DictOptions
opts (ClassDictInfo -> Name
className ClassDictInfo
cdi)
#if MIN_VERSION_template_haskell(2,15,0)
  instDec :: InstanceDec
instDec            = TySynEqn -> InstanceDec
TySynInstD (TySynEqn -> InstanceDec) -> TySynEqn -> InstanceDec
forall a b. (a -> b) -> a -> b
$
    Maybe [TyVarBndr ()] -> Pred -> Pred -> TySynEqn
TySynEqn Maybe [TyVarBndr ()]
forall a. Maybe a
Nothing (Name -> Pred
ConT ''Dict Pred -> Pred -> Pred
`AppT` Name -> [TyVarBndr BndrVis] -> Pred
appCon (ClassDictInfo -> Name
className ClassDictInfo
cdi) (ClassDictInfo -> [TyVarBndr BndrVis]
dictTyArgs ClassDictInfo
cdi))
                     (Name -> [TyVarBndr BndrVis] -> Pred
appCon Name
dname (ClassDictInfo -> [TyVarBndr BndrVis]
dictTyArgs ClassDictInfo
cdi))
  dictDec :: ([a] -> Name -> [TyVarBndr BndrVis] -> Maybe a -> t -> [a] -> t)
-> t -> t
dictDec [a] -> Name -> [TyVarBndr BndrVis] -> Maybe a -> t -> [a] -> t
con t
fields =
    [a] -> Name -> [TyVarBndr BndrVis] -> Maybe a -> t -> [a] -> t
con [] Name
dname (ClassDictInfo -> [TyVarBndr BndrVis]
dictTyArgs ClassDictInfo
cdi) Maybe a
forall a. Maybe a
Nothing t
fields []
#else
  instDec            = TySynInstD ''Dict $
      TySynEqn [appCon (className cdi) (dictTyArgs cdi)] $ appCon dname (dictTyArgs cdi)
  dictDec con fields =
    con [] dname (dictTyArgs cdi) Nothing fields []
#endif

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

-- | Converts info about class dictionary representation field to record field.

classDictToRecField :: ClassDictField -> VarBangType
classDictToRecField :: ClassDictField -> VarBangType
classDictToRecField ClassDictField
cdf = (
    ClassDictField -> Name
fieldName ClassDictField
cdf
  , SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness
  , (case ClassDictField -> ClassDictFieldSource
fieldSource ClassDictField
cdf of
      ClassDictFieldSource
Superclass -> Pred -> Pred -> Pred
AppT (Pred -> Pred -> Pred) -> Pred -> Pred -> Pred
forall a b. (a -> b) -> a -> b
$ Name -> Pred
ConT ''Dict
      ClassDictFieldSource
Method     -> Pred -> Pred
forall a. a -> a
id
    ) (Pred -> Pred) -> Pred -> Pred
forall a b. (a -> b) -> a -> b
$ ClassDictField -> Pred
origType ClassDictField
cdf
  )

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

-- | Info about class dictionary used by 'mkDict'.

data ClassDictInfo = CDI{
    ClassDictInfo -> Name
className   :: Name
  , ClassDictInfo -> [TyVarBndr BndrVis]
dictTyArgs  :: [TVB]
  , ClassDictInfo -> Name
dictConName :: Name
  , ClassDictInfo -> [ClassDictField]
dictFields  :: [ClassDictField]
  } deriving Int -> ClassDictInfo -> ClassName -> ClassName
[ClassDictInfo] -> ClassName -> ClassName
ClassDictInfo -> ClassName
(Int -> ClassDictInfo -> ClassName -> ClassName)
-> (ClassDictInfo -> ClassName)
-> ([ClassDictInfo] -> ClassName -> ClassName)
-> Show ClassDictInfo
forall a.
(Int -> a -> ClassName -> ClassName)
-> (a -> ClassName) -> ([a] -> ClassName -> ClassName) -> Show a
$cshowsPrec :: Int -> ClassDictInfo -> ClassName -> ClassName
showsPrec :: Int -> ClassDictInfo -> ClassName -> ClassName
$cshow :: ClassDictInfo -> ClassName
show :: ClassDictInfo -> ClassName
$cshowList :: [ClassDictInfo] -> ClassName -> ClassName
showList :: [ClassDictInfo] -> ClassName -> ClassName
Show

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

-- | Info about field in class dictionary used by 'mkDict'

data ClassDictField = CDF{
    ClassDictField -> Name
fieldName   :: Name
  , ClassDictField -> ClassDictFieldSource
fieldSource :: ClassDictFieldSource
  , ClassDictField -> Name
origName    :: Name
  , ClassDictField -> Pred
origType    :: Type
  } deriving Int -> ClassDictField -> ClassName -> ClassName
[ClassDictField] -> ClassName -> ClassName
ClassDictField -> ClassName
(Int -> ClassDictField -> ClassName -> ClassName)
-> (ClassDictField -> ClassName)
-> ([ClassDictField] -> ClassName -> ClassName)
-> Show ClassDictField
forall a.
(Int -> a -> ClassName -> ClassName)
-> (a -> ClassName) -> ([a] -> ClassName -> ClassName) -> Show a
$cshowsPrec :: Int -> ClassDictField -> ClassName -> ClassName
showsPrec :: Int -> ClassDictField -> ClassName -> ClassName
$cshow :: ClassDictField -> ClassName
show :: ClassDictField -> ClassName
$cshowList :: [ClassDictField] -> ClassName -> ClassName
showList :: [ClassDictField] -> ClassName -> ClassName
Show

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

-- | Source of field in class dictionary.

data ClassDictFieldSource = Superclass | Method deriving Int -> ClassDictFieldSource -> ClassName -> ClassName
[ClassDictFieldSource] -> ClassName -> ClassName
ClassDictFieldSource -> ClassName
(Int -> ClassDictFieldSource -> ClassName -> ClassName)
-> (ClassDictFieldSource -> ClassName)
-> ([ClassDictFieldSource] -> ClassName -> ClassName)
-> Show ClassDictFieldSource
forall a.
(Int -> a -> ClassName -> ClassName)
-> (a -> ClassName) -> ([a] -> ClassName -> ClassName) -> Show a
$cshowsPrec :: Int -> ClassDictFieldSource -> ClassName -> ClassName
showsPrec :: Int -> ClassDictFieldSource -> ClassName -> ClassName
$cshow :: ClassDictFieldSource -> ClassName
show :: ClassDictFieldSource -> ClassName
$cshowList :: [ClassDictFieldSource] -> ClassName -> ClassName
showList :: [ClassDictFieldSource] -> ClassName -> ClassName
Show

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

-- | Implement an instance using a dictionary. The argument must be an

-- expression quote with an explicit signature.

--

-- === Example

--

-- This declaration

--

-- @

-- 'instanceDict' [| 'FCI.Base.viaFunctor' @((->) e) :: 'Dict' ('Functor' (Reader e)) |]

-- @

--

-- generates the following 'Functor' instance for a user-defined type @Reader e@:

--

-- @

-- instance 'Functor' (Reader e) where

--   -- Methods obtained from the fields of the dictionary ('TCI.Data.Functor.viaFunctor' \@((->) e)).

--   'fmap' = 'TCI.Data.Functor._fmap' ('TCI.Data.Functor.viaFunctor' \@(((->) e)))

--   ('<$') = ('TCI.Data.Functor.|<$') ('TCI.Data.Functor.viaFunctor' \@(((->) e)))

-- @

--

-- The following syntaxes are supported to specify the instance head:

--

-- @

-- 'instanceDict' [| e ::                  'Dict' (C (T a)) |]  -- instance                  C (T a)

-- 'instanceDict' [| e ::           D a => 'Dict' (C (T a)) |]  -- instance           D a => C (T a)

-- 'instanceDict' [| e :: forall a. D a => 'Dict' (C (T a)) |]  -- instance forall a. D a => C (T a)

-- @

instanceDict :: Q Exp -> Q [Dec]
instanceDict :: Q Exp -> Q [InstanceDec]
instanceDict = Maybe Overlap -> Q Exp -> Q [InstanceDec]
instanceDictM Maybe Overlap
forall a. Maybe a
Nothing

-- | Variant of 'instanceDict' with an 'Overlap' annotation:

-- @{-\# OVERLAPPABLE \#-}@, etc.

--

-- @

-- 'instanceDict_' 'Overlappable'

-- 'instanceDict_' 'Overlapping'

-- 'instanceDict_' 'Overlaps'

-- 'instanceDict_' 'Incoherent'

-- @

instanceDict_ :: Overlap -> Q Exp -> Q [Dec]
instanceDict_ :: Overlap -> Q Exp -> Q [InstanceDec]
instanceDict_ = Maybe Overlap -> Q Exp -> Q [InstanceDec]
instanceDictM (Maybe Overlap -> Q Exp -> Q [InstanceDec])
-> (Overlap -> Maybe Overlap)
-> Overlap
-> Q Exp
-> Q [InstanceDec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Overlap -> Maybe Overlap
forall a. a -> Maybe a
Just

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

-- | 'instanceDict' and 'instanceDict_' as one function.

--

-- @

-- 'instanceDictM' 'Nothing'        = 'instanceDict'

-- 'instanceDictM' ('Just' overlap) = 'instanceDict_' overlap

-- @

instanceDictM :: Maybe Overlap -> Q Exp -> Q [Dec]
instanceDictM :: Maybe Overlap -> Q Exp -> Q [InstanceDec]
instanceDictM Maybe Overlap
overlap Q Exp
qe = do
  (Name
className, Cxt
cxt, Pred
ty, Exp
e) <- Exp -> Q (Name, Cxt, Pred, Exp)
splitDictExp (Exp -> Q (Name, Cxt, Pred, Exp))
-> Q Exp -> Q (Name, Cxt, Pred, Exp)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q Exp
qe
  InstanceDictInfo
info <- Name -> Pred -> Q InstanceDictInfo
getInstanceDictInfo Name
className Pred
ty
  Name
fresh <- ClassName -> Q Name
forall (m :: * -> *). Quote m => ClassName -> m Name
newName ClassName
"field"
  [InstanceDec] -> Q [InstanceDec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Overlap -> Cxt -> Pred -> [InstanceDec] -> InstanceDec
InstanceD Maybe Overlap
overlap Cxt
cxt Pred
ty (Exp -> InstanceDictInfo -> Name -> [InstanceDec]
instanceDictBody (Exp -> Exp
clean Exp
e) InstanceDictInfo
info Name
fresh)]

data InstanceDictInfo = InstanceDictInfo
  { InstanceDictInfo -> Name
idiConstrName :: Name
  , InstanceDictInfo -> [(Name, Name)]
idiMethodNames :: [(Name, Name)]  -- Method name, encoded field name

  }

classMethodNames :: Info -> [Name]
classMethodNames :: Info -> [Name]
classMethodNames (ClassI (ClassD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ [FunDep]
_ [InstanceDec]
decs) [InstanceDec]
_) = do
  SigD Name
name Pred
_ <- [InstanceDec]
decs
  Name -> [Name]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
name
classMethodNames Info
_ = ClassName -> [Name]
forall a. HasCallStack => ClassName -> a
error ClassName
"not a class"

dataNames :: Info -> (Name, [Name])
dataNames :: Info -> (Name, [Name])
dataNames (TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Pred
_ [Con
c] [DerivClause]
_)) = Con -> (Name, [Name])
dataNamesCon Con
c
dataNames (TyConI (NewtypeD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Pred
_ Con
c [DerivClause]
_)) = Con -> (Name, [Name])
dataNamesCon Con
c
dataNames Info
_ = ClassName -> (Name, [Name])
forall a. HasCallStack => ClassName -> a
error ClassName
"Not data"

dataNamesCon :: Con -> (Name, [Name])
dataNamesCon :: Con -> (Name, [Name])
dataNamesCon (RecC Name
conName [VarBangType]
fields) = (Name
conName, (\(Name
fname, Bang
_, Pred
_) -> Name
fname) (VarBangType -> Name) -> [VarBangType] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarBangType]
fields)
dataNamesCon (NormalC Name
conName [BangType]
_) = (Name
conName, [])
dataNamesCon Con
_ = ClassName -> (Name, [Name])
forall a. HasCallStack => ClassName -> a
error ClassName
"Bad data"

-- | Use the Dict instance to lookup the dictionary type associated with a type

-- class. This lets us implement the instance regardless of how the names

-- were mangled.

getInstanceDictInfo :: Name -> Type -> Q InstanceDictInfo
getInstanceDictInfo :: Name -> Pred -> Q InstanceDictInfo
getInstanceDictInfo Name
className Pred
cls = do
  [InstanceDec]
instances <- Name -> Cxt -> Q [InstanceDec]
reifyInstances ''Dict  [Pred
cls]
  case [InstanceDec]
instances of
    TySynInstD (TySynEqn Maybe [TyVarBndr ()]
_ Pred
_ Pred
rhs) : [InstanceDec]
_ | Just Name
dataName <- Pred -> Maybe Name
appHeadName Pred
rhs -> do
      [Name]
methodNames <- Info -> [Name]
classMethodNames (Info -> [Name]) -> Q Info -> Q [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
className
      (Name
conName, [Name]
fieldNames) <- Info -> (Name, [Name])
dataNames (Info -> (Name, [Name])) -> Q Info -> Q (Name, [Name])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
dataName
      InstanceDictInfo -> Q InstanceDictInfo
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InstanceDictInfo
        { idiConstrName :: Name
idiConstrName = Name
conName
          -- fields also include superclasses at the beginning,

          -- so we zip from the end to drop them.

        , idiMethodNames :: [(Name, Name)]
idiMethodNames = [(Name, Name)] -> [(Name, Name)]
forall a. [a] -> [a]
reverse ([Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
methodNames) ([Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
fieldNames))
        }
    [] -> ClassName -> Q InstanceDictInfo
forall a. HasCallStack => ClassName -> a
error ClassName
"Dictionary not found. Did you forget to mkDict?"
    [InstanceDec]
_ -> ClassName -> Q InstanceDictInfo
forall a. HasCallStack => ClassName -> a
error (ClassName
"Should not happen. " ClassName -> ClassName -> ClassName
forall a. [a] -> [a] -> [a]
++ [InstanceDec] -> ClassName
forall a. Ppr a => a -> ClassName
pprint [InstanceDec]
instances)

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

-- | Extract the name of the class, the instance context, the instance head,

-- and the dictionary expression, cleaning it up a bit (remove context and @forall@).

splitDictExp :: Exp -> Q (Name, Cxt, Type, Exp)
splitDictExp :: Exp -> Q (Name, Cxt, Pred, Exp)
splitDictExp Exp
e0 = do
  (Cxt
cxt, Pred
t, Exp
e) <- case Exp
e0 of
    SigE Exp
e (ForallT [TyVarBndr Specificity]
_ Cxt
cxt (AppT Pred
_Dict Pred
t)) -> (Cxt, Pred, Exp) -> Q (Cxt, Pred, Exp)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cxt
cxt, Pred
t, Exp -> Pred -> Exp
SigE Exp
e (Pred -> Pred -> Pred
AppT Pred
_Dict Pred
t))
    SigE Exp
_ (AppT Pred
_ Pred
t) -> (Cxt, Pred, Exp) -> Q (Cxt, Pred, Exp)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Pred
t, Exp
e0)
    Exp
_ -> Exp -> Q (Cxt, Pred, Exp)
forall a. Exp -> Q a
badExp Exp
e0
  case Pred -> Maybe Name
appHeadName Pred
t of
    Maybe Name
Nothing -> Exp -> Q (Name, Cxt, Pred, Exp)
forall a. Exp -> Q a
badExp Exp
e0
    Just Name
n -> (Name, Cxt, Pred, Exp) -> Q (Name, Cxt, Pred, Exp)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
n, Cxt
cxt, Pred
t, Exp
e)

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

-- | Build the instance body for 'instanceDict'.

instanceDictBody :: Exp -> InstanceDictInfo -> Name -> [Dec]
instanceDictBody :: Exp -> InstanceDictInfo -> Name -> [InstanceDec]
instanceDictBody Exp
e InstanceDictInfo
info Name
fresh = (Name, Name) -> InstanceDec
mkMethod ((Name, Name) -> InstanceDec) -> [(Name, Name)] -> [InstanceDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InstanceDictInfo -> [(Name, Name)]
idiMethodNames InstanceDictInfo
info
  where
    mkMethod :: (Name, Name) -> Dec
    mkMethod :: (Name, Name) -> InstanceDec
mkMethod (Name
methodName, Name
fieldName) = Name -> [Clause] -> InstanceDec
FunD Name
methodName [[Pat] -> Body -> [InstanceDec] -> Clause
Clause [] (Exp -> Body
NormalB (Name -> Exp
body Name
fieldName)) []]
    body :: Name -> Exp
body Name
fieldName = Exp -> Exp -> Exp
AppE Exp
fieldLambda Exp
e
      where
        -- Field accessor expression (\(C { field = f }) -> f)

        -- With DuplicateRecordFields, we cannot use a field name @field@ as an accessor function.

        -- I could use OverloadedRecordDot but this is very new, and I'd like to keep

        -- backwards compatibility for now.

        fieldLambda :: Exp
fieldLambda = [Pat] -> Exp -> Exp
LamE [Name -> [FieldPat] -> Pat
RecP (InstanceDictInfo -> Name
idiConstrName InstanceDictInfo
info) [(Name
fieldName, Name -> Pat
VarP Name
fresh)]] (Name -> Exp
VarE Name
fresh)

-- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/14848

-- Fields declared under DuplicateRecordFields are munged and completely unusable in TH quotes.

-- So we clean them up.

clean :: Exp -> Exp
clean :: Exp -> Exp
clean = (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)

-- "$sel:field:Constructor" -> "field"

cleanName :: Name -> Name
cleanName :: Name -> Name
cleanName Name
n | Just ClassName
m <- ClassName -> ClassName -> Maybe ClassName
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix ClassName
"$sel:" (Name -> ClassName
nameBase Name
n) = ClassName -> Name
mkName (ClassName -> ClassName
cleann ClassName
m)
  where
    cleann :: ClassName -> ClassName
cleann = ClassName -> ClassName
forall a. [a] -> [a]
reverse (ClassName -> ClassName)
-> (ClassName -> ClassName) -> ClassName -> ClassName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ClassName -> ClassName
forall a. Int -> [a] -> [a]
drop Int
1 (ClassName -> ClassName)
-> (ClassName -> ClassName) -> ClassName -> ClassName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ClassName -> ClassName
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') (ClassName -> ClassName)
-> (ClassName -> ClassName) -> ClassName -> ClassName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassName -> ClassName
forall a. [a] -> [a]
reverse
cleanName Name
n = Name
n

everywhere :: (forall a. Data a => a -> a)
           -> (forall a. Data a => a -> a)
everywhere :: (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere forall a. Data a => a -> a
f = a -> a
forall a. Data a => a -> a
go
  where
    go :: forall a. Data a => a -> a
    go :: forall a. Data a => a -> a
go = a -> a
forall a. Data a => a -> a
f (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Data a => a -> a) -> a -> a
forall a. Data a => (forall a. Data a => a -> a) -> a -> a
gmapT b -> b
forall a. Data a => a -> a
go

mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT :: forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT b -> b
f = (a -> a) -> ((a -> a) -> a -> a) -> Maybe (a -> a) -> a -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a -> a
forall a. a -> a
id (a -> a) -> a -> a
forall a. a -> a
id ((b -> b) -> Maybe (a -> a)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b -> b
f)

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

-- | Error for 'instanceDict'.

badExp :: Exp -> Q a
badExp :: forall a. Exp -> Q a
badExp Exp
e = ClassName -> Q a
forall a. ClassName -> Q a
forall (m :: * -> *) a. MonadFail m => ClassName -> m a
fail
  ("instanceDict: expected a quasiquote of the form \
[| e :: Dict (C (T a)) |] or [| e :: forall a. C0 a => Dict (C (T a)) |]\n\t\
got: [| " ++ pprint e ++ " |]")