{-# LANGUAGE BlockArguments  #-}
{-# LANGUAGE CPP             #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnicodeSyntax   #-}
{-# LANGUAGE ViewPatterns    #-}

module GHC.Definitions.TH (
  Config (..), autoConfig, defaultConfig,
  makeDefinitions, makeDefinitionsWithConfig,
  makePattern
) where

import Data.Char       (toLower)
import Data.Constraint (Dict (..))
import Data.Maybe      (fromJust, fromMaybe)

import Language.Haskell.TH.Lib    (appE, bang, bangType, bindS, clause, conT,
                                   cxt, dataD, doE, explBidir, fieldExp,
                                   forallT, funD, implicitParamBindD,
                                   implicitParamT, implicitParamVarE, letS,
                                   noBindS, noSourceStrictness,
                                   noSourceUnpackedness, normalB, patSynD,
                                   patSynSigD, prefixPatSyn, recC, recConE,
                                   sigD, tySynD, varBangType, varE, varP, varT)
import Language.Haskell.TH.Syntax (Dec, Exp, Info (..), Lift (..), Name, Pat, Q,
                                   Quasi (..), Stmt, Type (..), VarBangType,
                                   mkName, nameBase, nameModule)

import qualified GHC.Core.Class as GHC
import qualified GHC.Plugins    as GHC
import qualified GHC.Tc.Plugin  as GHC

data Config = Config
  { Config -> String
recordName     ∷ String
  , Config -> String
implicitName   ∷ String
  , Config -> String
constraintName ∷ String
  , Config -> String
functionName   ∷ String
  , Config -> [(Char, String)]
operatorTable  ∷ [(Char, String)]
  }

autoConfig ∷ String → Config
autoConfig :: String -> Config
autoConfig String
name = Config :: String -> String -> String -> String -> [(Char, String)] -> Config
Config
  { recordName :: String
recordName     = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Record"
  , implicitName :: String
implicitName   = String -> String
lower String
name
  , constraintName :: String
constraintName = String
name
  , functionName :: String
functionName   = String
"find" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
  , operatorTable :: [(Char, String)]
operatorTable  =
      [ (Char
'+',  String
"Plus")
      , (Char
'-',  String
"Minus")
      , (Char
'*',  String
"Star")
      , (Char
'=',  String
"Equals")
      , (Char
'#',  String
"Hash")
      , (Char
'!',  String
"Bang")
      , (Char
'@',  String
"At")
      , (Char
'$',  String
"Dollar")
      , (Char
'%',  String
"Percent")
      , (Char
'^',  String
"Accent")
      , (Char
'&',  String
"And")
      , (Char
'<',  String
"Less")
      , (Char
'>',  String
"Greater")
      , (Char
'?',  String
"Question")
      , (Char
'|',  String
"Pipe")
      , (Char
'/',  String
"Slash")
      , (Char
'\\', String
"Backslash")
      , (Char
'.',  String
"Dot")
      , (Char
'~',  String
"Tilde")
      ]
  }

defaultConfig ∷ Config
defaultConfig :: Config
defaultConfig = String -> Config
autoConfig String
"Definitions"

-- | Given a list of names @names@, @makeDefinitions@ constructs the following:
--
-- 1. A constraint @Definitions@.
-- 2. A function @findDefinitions ∷ 'GHC.TcPluginM' ('Dict' Definitions)@
-- 3. For each @name ∈ names@, a function @name⟨type⟩ ∷ Definitions ⇒
--    ⟨type⟩@, where @⟨type⟩@ is determined by whatever @name@ refers to, i.e. a
--    data constructor @('GHC.DataCon')@, function or value @('GHC.Var')@, or
--    type constructor @('GHC.TyCon')@.
makeDefinitions ∷ [Name] → Q [Dec]
makeDefinitions :: [Name] -> Q [Dec]
makeDefinitions = Config -> [Name] -> Q [Dec]
makeDefinitionsWithConfig Config
defaultConfig

-- | Like 'makeDefinitions', but allows some control over the generated names.
makeDefinitionsWithConfig ∷ Config → [Name] → Q [Dec]
makeDefinitionsWithConfig :: Config -> [Name] -> Q [Dec]
makeDefinitionsWithConfig
    Config
      { recordName :: Config -> String
recordName     = (String -> Name
mkName → Name
recordN)
      , implicitName :: Config -> String
implicitName   = String
implicitN
      , constraintName :: Config -> String
constraintName = (String -> Name
mkName → Name
constraintN)
      , functionName :: Config -> String
functionName   = (String -> Name
mkName → Name
functionN)
      , operatorTable :: Config -> [(Char, String)]
operatorTable  = [(Char, String)]
opTable
      }
    [Name]
names =
  Q Dec
mkConstraintTy Q Dec -> Q [Dec] -> Q [Dec]
forall (m :: * -> *) a. Applicative m => m a -> m [a] -> m [a]
+:
  Q Dec
mkRecordTy     Q Dec -> Q [Dec] -> Q [Dec]
forall (m :: * -> *) a. Applicative m => m a -> m [a] -> m [a]
+:
  Q [Dec]
mkFunction     Q [Dec] -> Q [Dec] -> Q [Dec]
forall (m :: * -> *) a. Applicative m => m [a] -> m [a] -> m [a]
+++
  (Name -> Q [Dec]) -> [Name] -> Q [Dec]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Name -> Q [Dec]
mkAccessor [Name]
names
 where
  concatMapM ∷ Monad m ⇒ (a → m [b]) → [a] → m [b]
  concatMapM :: (a -> m [b]) -> [a] -> m [b]
concatMapM a -> m [b]
f = ([[b]] -> [b]) -> m [[b]] -> m [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[b]] -> [b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[b]] -> m [b]) -> ([a] -> m [[b]]) -> [a] -> m [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m [b]) -> [a] -> m [[b]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> m [b]
f

  mkConstraintTy ∷  Q Dec
  mkConstraintTy :: Q Dec
mkConstraintTy = Name -> [TyVarBndr] -> TypeQ -> Q Dec
tySynD Name
constraintN [] (String -> TypeQ -> TypeQ
implicitParamT String
implicitN (Name -> TypeQ
conT Name
recordN))

  mkRecordTy ∷ Q Dec
  mkRecordTy :: Q Dec
mkRecordTy = CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> [ConQ]
-> [DerivClauseQ]
-> Q Dec
dataD ([TypeQ] -> CxtQ
cxt []) Name
recordN [] Maybe Kind
forall a. Maybe a
Nothing [Name -> [VarBangTypeQ] -> ConQ
recC Name
recordN ((Name -> VarBangTypeQ) -> [Name] -> [VarBangTypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> VarBangTypeQ
mkField [Name]
names)] []

  mkFieldName ∷ Name → Q Name
  mkFieldName :: Name -> Q Name
mkFieldName = (Name -> Name) -> Q Name -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) (Q Name -> Q Name) -> (Name -> Q Name) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Name
forall (m :: * -> *). Quasi m => Name -> m Name
mkAccessorName

  mkFieldName' ∷ Name → Q Name
  mkFieldName' :: Name -> Q Name
mkFieldName' = (Name -> Name) -> Q Name -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"__" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) (Q Name -> Q Name) -> (Name -> Q Name) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Name
forall (m :: * -> *). Quasi m => Name -> m Name
mkAccessorName

  mkField ∷ Name → Q VarBangType
  mkField :: Name -> VarBangTypeQ
mkField Name
name = do
    Name
name' ← Name -> Q Name
mkFieldName Name
name
    Name -> BangTypeQ -> VarBangTypeQ
varBangType Name
name' (BangQ -> TypeQ -> BangTypeQ
bangType
      (SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
bang SourceUnpackednessQ
noSourceUnpackedness SourceStrictnessQ
noSourceStrictness)
      (Name -> TypeQ
mkFieldType Name
name))

  mkFieldType ∷ Name → Q Type
  mkFieldType :: Name -> TypeQ
mkFieldType Name
name = do
    Info
info ← Name -> Q Info
forall (m :: * -> *). Quasi m => Name -> m Info
qReify Name
name
    case Info
info of
      ClassI {}     → [t|GHC.Class|]
      ClassOpI {}   → [t|GHC.Var|]
      TyConI {}     → [t|GHC.TyCon|]
      FamilyI {}    → [t|GHC.TyCon|]
      PrimTyConI {} → [t|GHC.TyCon|]
      DataConI {}   → [t|GHC.DataCon|]
      VarI {}       → [t|GHC.Var|]
      PatSynI {}    → String -> TypeQ
forall a. HasCallStack => String -> a
error String
"Don't know what to do with pattern synonyms yet..."
      TyVarI {}     → String -> TypeQ
forall a. HasCallStack => String -> a
error String
"Unexpected type variable name"

  mkFunction ∷ Q [Dec]
  mkFunction :: Q [Dec]
mkFunction = [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
    [ Name -> TypeQ -> Q Dec
sigD Name
functionN [t| GHC.TcPluginM (Dict $(conT constraintN)) |]
    , Name -> [ClauseQ] -> Q Dec
funD Name
functionN [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
        (ExpQ -> BodyQ
normalB ([StmtQ] -> ExpQ
doE
          ( (Name -> StmtQ) -> [Name] -> [StmtQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> StmtQ
mkFunctionStmt [Name]
names [StmtQ] -> [StmtQ] -> [StmtQ]
forall a. [a] -> [a] -> [a]
++
          [ [Q Dec] -> StmtQ
letS [String -> ExpQ -> Q Dec
implicitParamBindD String
implicitN (Name -> [Q (Name, Exp)] -> ExpQ
recConE Name
recordN ((Name -> Q (Name, Exp)) -> [Name] -> [Q (Name, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q (Name, Exp)
mkRecordExp [Name]
names))]
          , ExpQ -> StmtQ
noBindS [e|return Dict|]
          ] )))
        []]
    ]

  mkFunctionStmt ∷ Name → Q Stmt
  mkFunctionStmt :: Name -> StmtQ
mkFunctionStmt Name
name = do
    Name
name' ← Name -> Q Name
mkFieldName' Name
name
    PatQ -> ExpQ -> StmtQ
bindS (Name -> PatQ
varP Name
name') (Name -> ExpQ
mkFunctionExp Name
name)

  mkFunctionExp ∷ Name → Q Exp
  mkFunctionExp :: Name -> ExpQ
mkFunctionExp Name
name = do
    let md :: ExpQ
md = String -> ExpQ
forall t. Lift t => t -> ExpQ
lift (Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Name -> Maybe String
nameModule Name
name))
        on :: ExpQ
on = String -> ExpQ
forall t. Lift t => t -> ExpQ
lift (Name -> String
alphaNumNameBase Name
name)
    Info
info ← Name -> Q Info
forall (m :: * -> *). Quasi m => Name -> m Info
qReify Name
name
    case Info
info of
      ClassI {}     → [e|lookupClass   $md $on|]
      ClassOpI {}   → [e|lookupVar     $md $on|]
      TyConI {}     → [e|lookupTyCon   $md $on|]
      FamilyI {}    → [e|lookupTyCon   $md $on|]
      PrimTyConI {} → [e|lookupTyCon   $md $on|]
      DataConI {}   → [e|lookupDataCon $md $on|]
      VarI {}       → [e|lookupVar     $md $on|]
      PatSynI {}    → String -> ExpQ
forall a. HasCallStack => String -> a
error String
"Don't know what to do with pattern synonyms yet..."
      TyVarI {}     → String -> ExpQ
forall a. HasCallStack => String -> a
error String
"Unexpeced type variable name"

  mkRecordExp ∷ Name → Q (Name, Exp)
  mkRecordExp :: Name -> Q (Name, Exp)
mkRecordExp Name
name = do
    Name
name'  ← Name -> Q Name
mkFieldName  Name
name
    Name
name'' ← Name -> Q Name
mkFieldName' Name
name
    Name -> ExpQ -> Q (Name, Exp)
fieldExp Name
name' (Name -> ExpQ
varE Name
name'')

  mkAccessor ∷ Name → Q [Dec]
  mkAccessor :: Name -> Q [Dec]
mkAccessor Name
name = do
    Name
acc     ← Name -> Q Name
forall (m :: * -> *). Quasi m => Name -> m Name
mkAccessorName Name
name
    Bool
promote ← Name -> Q Bool
forall (m :: * -> *). Quasi m => Name -> m Bool
isDataCon      Name
name
    Name
name'   ← Name -> Q Name
mkFieldName    Name
name
    let defaultDefs :: [Q Dec]
defaultDefs =
          [ Name -> TypeQ -> Q Dec
sigD Name
acc [t| $(conT constraintN) ⇒ $(mkFieldType name) |]
          , Name -> [ClauseQ] -> Q Dec
funD Name
acc [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
              (ExpQ -> BodyQ
normalB
                (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
name') (String -> ExpQ
implicitParamVarE String
implicitN)))
              []]
          ]
        promotedDefs :: [Q Dec]
promotedDefs =
          [ Name -> TypeQ -> Q Dec
sigD (Name -> Name
mkPromotedAccessorName Name
name) [t| $(conT constraintN) ⇒ GHC.TyCon |]
          , Name -> [ClauseQ] -> Q Dec
funD (Name -> Name
mkPromotedAccessorName Name
name) [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [e| GHC.promoteDataCon $(varE acc)|]) []]
          ]
    [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Dec]
defaultDefs [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++ (if Bool
promote then [Q Dec]
promotedDefs else []))

  mkAccessorName ∷ Quasi m ⇒ Name → m Name
  mkAccessorName :: Name -> m Name
mkAccessorName Name
name = do
    Info
info ← Name -> m Info
forall (m :: * -> *). Quasi m => Name -> m Info
qReify Name
name
    Name -> m Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> m Name) -> (String -> Name) -> String -> m Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Name) -> (String -> String) -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
lower (String -> m Name) -> String -> m Name
forall a b. (a -> b) -> a -> b
$ case Info
info of
      ClassI {}     → Name -> String
alphaNumNameBase Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Class"
      ClassOpI {}   → Name -> String
alphaNumNameBase Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Var"
      TyConI {}     → Name -> String
alphaNumNameBase Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"TyCon"
      FamilyI {}    → Name -> String
alphaNumNameBase Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"TyCon"
      PrimTyConI {} → Name -> String
alphaNumNameBase Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"TyCon"
      DataConI {}   → Name -> String
alphaNumNameBase Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"DataCon"
      VarI {}       → Name -> String
alphaNumNameBase Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Var"
      PatSynI {}    → String -> String
forall a. HasCallStack => String -> a
error String
"Don't know what to do with pattern synonyms yet..."
      TyVarI {}     → String -> String
forall a. HasCallStack => String -> a
error String
"Unexpected type variable name"

  mkPromotedAccessorName ∷ Name → Name
  mkPromotedAccessorName :: Name -> Name
mkPromotedAccessorName Name
name = String -> Name
mkName (String
"promoted" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
alphaNumNameBase Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"TyCon")

  isDataCon ∷ Quasi m ⇒ Name → m Bool
  isDataCon :: Name -> m Bool
isDataCon Name
name = do
    Info
info ← Name -> m Info
forall (m :: * -> *). Quasi m => Name -> m Info
qReify Name
name
    case Info
info of
      DataConI {} → Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      Info
_           → Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

  alphaNumNameBase ∷ Name → String
  alphaNumNameBase :: Name -> String
alphaNumNameBase = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Char
c → String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe [Char
c] (Char -> [(Char, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
c [(Char, String)]
opTable)) (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase

-- | Constructs a pattern synonym for a given 'GHC.TyCon', 'GHC.DataCon', or
-- 'GHC.Var'.
makePattern ∷ String → Name → Q [Dec]
makePattern :: String -> Name -> Q [Dec]
makePattern (String -> Name
mkName → Name
patName) Name
valName = do
  Name
x  ← String -> Q Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"x"
  Kind
ty ← Name -> TypeQ
forall (m :: * -> *). Quasi m => Name -> m Kind
qReifyType Name
valName
  [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
    [ Name -> TypeQ -> Q Dec
patSynSigD Name
patName (Kind -> TypeQ
mkPatternType Kind
ty)
    , Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> Q Dec
patSynD    Name
patName ([Name] -> PatSynArgsQ
prefixPatSyn [Name
x])
        ([ClauseQ] -> PatSynDirQ
explBidir [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
x] (ExpQ -> BodyQ
normalB (Kind -> ExpQ -> ExpQ
mkPatternExp Kind
ty (Name -> ExpQ
varE Name
x))) []])
        (Kind -> PatQ -> PatQ
mkPatternPat Kind
ty (Name -> PatQ
varP Name
x))
    ]
 where
  mkPatternType ∷ Type → Q Type
  mkPatternType :: Kind -> TypeQ
mkPatternType (ForallT [TyVarBndr]
_ Cxt
ctxt Kind
ty) = [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT [] (Cxt -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
ctxt) (Kind -> TypeQ
mkPatternType Kind
ty)
  mkPatternType (ConT Name
name)
    | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''GHC.TyCon
   Bool -> Bool -> Bool
|| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''GHC.Class   = [t| [GHC.Type] → GHC.Type |]
    | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''GHC.Var
   Bool -> Bool -> Bool
|| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''GHC.DataCon = String -> Q Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"a" Q Name -> (Name -> TypeQ) -> TypeQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
a → [t| [GHC.Expr $(varT a)] → GHC.Expr $(varT a) |]
  mkPatternType Kind
ty = String -> TypeQ
forall a. HasCallStack => String -> a
error (String
"Unexpected type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Show a => a -> String
show Kind
ty)

  mkPatternPat ∷ Type → Q Pat → Q Pat
  mkPatternPat :: Kind -> PatQ -> PatQ
mkPatternPat (ForallT [TyVarBndr]
_ Cxt
_ Kind
ty) PatQ
pat = Kind -> PatQ -> PatQ
mkPatternPat Kind
ty PatQ
pat
  mkPatternPat (ConT Name
name) PatQ
pat
    | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''GHC.TyCon   = [p|(GHC.splitTyConApp_maybe → Just ((== $(varE valName)) → True, $pat))|]
    | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''GHC.Class   = [p|(GHC.splitTyConApp_maybe → Just ((== GHC.classTyCon $(varE valName)) → True, $pat))|]
    | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''GHC.Var     = [p|(GHC.collectArgs → (GHC.Var ((== $(varE valName)) → True), $pat))|]
    | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''GHC.DataCon = [p|(GHC.collectArgs → (GHC.Var ((== GHC.dataConWorkId $(varE valName)) → True), $pat))|]
  mkPatternPat Kind
ty PatQ
_ = String -> PatQ
forall a. HasCallStack => String -> a
error (String
"Unexpected type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Show a => a -> String
show Kind
ty)

  mkPatternExp ∷ Type → Q Exp → Q Exp
  mkPatternExp :: Kind -> ExpQ -> ExpQ
mkPatternExp (ForallT [TyVarBndr]
_ Cxt
_ Kind
ty) ExpQ
pat = Kind -> ExpQ -> ExpQ
mkPatternExp Kind
ty ExpQ
pat
  mkPatternExp (ConT Name
name) ExpQ
pat
    | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''GHC.TyCon   = [e|GHC.mkTyConApp $(varE valName) $pat|]
    | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''GHC.Class   = [e|GHC.mkTyConApp (GHC.classTyCon $(varE valName)) $pat|]
    | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''GHC.Var     = [e|GHC.mkApps (GHC.Var $(varE valName)) $pat|]
    | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''GHC.DataCon = [e|GHC.mkConApp $(varE valName) $pat|]
  mkPatternExp Kind
ty ExpQ
_ = String -> ExpQ
forall a. HasCallStack => String -> a
error (String
"Unexpected type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Show a => a -> String
show Kind
ty)

lookupClass ∷ String → String → GHC.TcPluginM GHC.Class
lookupClass :: String -> String -> TcPluginM Class
lookupClass String
mn String
on = do
  Module
md ← String -> TcPluginM Module
lookupModule String
mn
  Name -> TcPluginM Class
GHC.tcLookupClass (Name -> TcPluginM Class) -> TcPluginM Name -> TcPluginM Class
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Module -> OccName -> TcPluginM Name
GHC.lookupOrig Module
md (String -> OccName
GHC.mkClsOcc String
on)

lookupTyCon ∷ String → String → GHC.TcPluginM GHC.TyCon
lookupTyCon :: String -> String -> TcPluginM TyCon
lookupTyCon String
mn String
on = do
  Module
md ← String -> TcPluginM Module
lookupModule String
mn
  Name -> TcPluginM TyCon
GHC.tcLookupTyCon (Name -> TcPluginM TyCon) -> TcPluginM Name -> TcPluginM TyCon
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Module -> OccName -> TcPluginM Name
GHC.lookupOrig Module
md (String -> OccName
GHC.mkTcOcc String
on)

lookupDataCon ∷ String → String → GHC.TcPluginM GHC.DataCon
lookupDataCon :: String -> String -> TcPluginM DataCon
lookupDataCon String
mn String
on = do
  Module
md ← String -> TcPluginM Module
lookupModule String
mn
  Name -> TcPluginM DataCon
GHC.tcLookupDataCon (Name -> TcPluginM DataCon) -> TcPluginM Name -> TcPluginM DataCon
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Module -> OccName -> TcPluginM Name
GHC.lookupOrig Module
md (String -> OccName
GHC.mkDataOcc String
on)

lookupVar ∷ String → String → GHC.TcPluginM GHC.Var
lookupVar :: String -> String -> TcPluginM Var
lookupVar String
mn String
on = do
  Module
md ← String -> TcPluginM Module
lookupModule String
mn
  Name -> TcPluginM Var
GHC.tcLookupId (Name -> TcPluginM Var) -> TcPluginM Name -> TcPluginM Var
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Module -> OccName -> TcPluginM Name
GHC.lookupOrig Module
md (String -> OccName
GHC.mkVarOcc String
on)

lookupModule ∷ String → GHC.TcPluginM GHC.Module
lookupModule :: String -> TcPluginM Module
lookupModule String
mn = do
  FindResult
result ← ModuleName -> Maybe FastString -> TcPluginM FindResult
GHC.findImportedModule (String -> ModuleName
GHC.mkModuleName String
mn) Maybe FastString
forall a. Maybe a
Nothing
  case FindResult
result of
    GHC.Found ModLocation
_ Module
md → Module -> TcPluginM Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
md
    FindResult
_              → do
      String -> SDoc -> TcPluginM ()
GHC.tcPluginTrace String
"[ghc-definitions-th]" (String -> SDoc
GHC.text (String
"Could not locate module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn))
      String -> TcPluginM Module
forall a. HasCallStack => String -> a
error String
"lookupModule: failed"

lower ∷ String → String
lower :: String -> String
lower String
""     = String
""
lower (Char
x:String
xs) = Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs

infixr +:, +++

(+:) ∷ Applicative m ⇒ m a → m [a] → m [a]
m a
x +: :: m a -> m [a] -> m [a]
+: m [a]
xs = (:) (a -> [a] -> [a]) -> m a -> m ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
x m ([a] -> [a]) -> m [a] -> m [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m [a]
xs

(+++) ∷ Applicative m ⇒ m [a] → m [a] → m [a]
m [a]
xs +++ :: m [a] -> m [a] -> m [a]
+++ m [a]
ys = [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) ([a] -> [a] -> [a]) -> m [a] -> m ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [a]
xs m ([a] -> [a]) -> m [a] -> m [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m [a]
ys