{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-unused-local-binds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NamedFieldPuns #-}

module Test.MockCat.TH
  ( showExp,
    expectByExpr,
    makeMock,
    makeAutoLiftMock,
    makePartialMock,
    makeAutoLiftPartialMock,
  )
where

import Control.Monad (unless)
import Data.List (elemIndex, nub)
import Data.Maybe (catMaybes)
import qualified Data.Map.Strict as Map

import Language.Haskell.TH
  ( Cxt,
    Dec (..),
    Exp (..),
    Extension (..),
    Info (..),
    Lit (..),
    Name,
    Pat (..),
    Pred,
    Q,
    TyVarBndr (..),
    TySynEqn (..),
    TypeFamilyHead (..),
    Type (..),
    isExtEnabled,
    mkName,
    pprint,
    reify,
  )
import Language.Haskell.TH.Lib
import Language.Haskell.TH.PprLib (Doc, hcat, parens, text)
import Language.Haskell.TH.Syntax (nameBase)
import Test.MockCat.Mock ()
import Test.MockCat.MockT
import Test.MockCat.TH.ClassAnalysis
  ( ClassName2VarNames(..),
    VarName2ClassNames(..),
    filterClassInfo,
    filterMonadicVarInfos,
    getClassName,
    getClassNames,
    toClassInfos,
    VarAppliedType(..),
    applyVarAppliedTypes )
import Test.MockCat.TH.ContextBuilder
  ( MockType (..),
    buildContext,
    getTypeVarName,
    getTypeVarNames,
    tyVarBndrToType,
    applyFamilyArg,
    convertTyVarBndr
  )
import Test.MockCat.TH.TypeUtils
  ( splitApps,
    substituteType
  )
import Test.MockCat.TH.FunctionBuilder
  ( createFnName,
    typeToNames,
    safeIndex,
    MockFnContext(..)
    , buildMockFnContext
    , buildMockFnDeclarations
    , createNoInlinePragma
    , generateInstanceMockFnBody
    , generateInstanceRealFnBody
  )
import Test.MockCat.TH.Types (MockOptions(..), options)
import Test.MockCat.Verify ()
import Test.MockCat.Param
import Prelude as P


showExp :: Q Exp -> Q String
showExp :: Q Exp -> Q String
showExp Q Exp
qexp = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (Exp -> Doc) -> Exp -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Doc
pprintExp (Exp -> String) -> Q Exp -> Q String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp
qexp

pprintExp :: Exp -> Doc
pprintExp :: Exp -> Doc
pprintExp (VarE Name
name) = String -> Doc
text (Name -> String
nameBase Name
name)
pprintExp (ConE Name
name) = String -> Doc
text (Name -> String
nameBase Name
name)
pprintExp (LitE Lit
lit) = Lit -> Doc
pprintLit Lit
lit
pprintExp (AppE Exp
e1 Exp
e2) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat [Exp -> Doc
pprintExp Exp
e1, String -> Doc
text String
" ", Exp -> Doc
pprintExp Exp
e2]
pprintExp (InfixE Maybe Exp
e1 Exp
e2 Maybe Exp
e3) = Maybe Exp -> Exp -> Maybe Exp -> Doc
pprintInfixE Maybe Exp
e1 Exp
e2 Maybe Exp
e3
pprintExp (LamE [Pat]
pats Exp
body) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat [String -> Doc
text String
"\\", [Pat] -> Doc
pprintPats [Pat]
pats, String -> Doc
text String
" -> ", Exp -> Doc
pprintExp Exp
body]
pprintExp (TupE [Maybe Exp]
exps) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat ((Maybe Exp -> Doc) -> [Maybe Exp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> (Exp -> Doc) -> Maybe Exp -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Doc
text String
"") Exp -> Doc
pprintExp) [Maybe Exp]
exps)
pprintExp (ListE [Exp]
exps) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat ((Exp -> Doc) -> [Exp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Doc
pprintExp [Exp]
exps)
pprintExp (SigE Exp
e Type
_) = Exp -> Doc
pprintExp Exp
e
pprintExp Exp
x = String -> Doc
text (Exp -> String
forall a. Ppr a => a -> String
pprint Exp
x)

pprintInfixE :: Maybe Exp -> Exp -> Maybe Exp -> Doc
pprintInfixE :: Maybe Exp -> Exp -> Maybe Exp -> Doc
pprintInfixE Maybe Exp
e1 Exp
e2 Maybe Exp
e3 =
  Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    [Doc] -> Doc
hcat
      [ Doc -> (Exp -> Doc) -> Maybe Exp -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Doc
text String
"") Exp -> Doc
pprintExp Maybe Exp
e1,
        Doc -> (Exp -> Doc) -> Maybe Exp -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Doc
text String
"") (Doc -> Exp -> Doc
forall a b. a -> b -> a
const (String -> Doc
text String
" ")) Maybe Exp
e1,
        Exp -> Doc
pprintExp Exp
e2,
        String -> Doc
text String
" ",
        Doc -> (Exp -> Doc) -> Maybe Exp -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Doc
text String
"") Exp -> Doc
pprintExp Maybe Exp
e3
      ]

pprintPats :: [Pat] -> Doc
pprintPats :: [Pat] -> Doc
pprintPats = [Doc] -> Doc
hcat ([Doc] -> Doc) -> ([Pat] -> [Doc]) -> [Pat] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pat -> Doc) -> [Pat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Pat -> Doc
pprintPat

pprintPat :: Pat -> Doc
pprintPat :: Pat -> Doc
pprintPat (VarP Name
name) = String -> Doc
text (Name -> String
nameBase Name
name)
pprintPat Pat
p = String -> Doc
text (Pat -> String
forall a. Ppr a => a -> String
pprint Pat
p)

pprintLit :: Lit -> Doc
pprintLit :: Lit -> Doc
pprintLit (IntegerL Integer
n) = String -> Doc
text (Integer -> String
forall a. Show a => a -> String
show Integer
n)
pprintLit (RationalL Rational
r) = String -> Doc
text (Rational -> String
forall a. Show a => a -> String
show Rational
r)
pprintLit (StringL String
s) = String -> Doc
text (String -> String
forall a. Show a => a -> String
show String
s)
pprintLit (CharL Char
c) = String -> Doc
text (Char -> String
forall a. Show a => a -> String
show Char
c)
pprintLit Lit
l = String -> Doc
text (Lit -> String
forall a. Ppr a => a -> String
pprint Lit
l)

-- | Create a conditional parameter based on @Q Exp@.
--
--  In calling a mock function, if the argument does not satisfy this condition, an error is raised.
--
--  The conditional expression is displayed in the error message.
expectByExpr :: Q Exp -> Q Exp
expectByExpr :: Q Exp -> Q Exp
expectByExpr Q Exp
qf = do
  String
str <- Q Exp -> Q String
showExp Q Exp
qf
  [|ExpectCondition $Q Exp
qf str|]



-- | Create a mock of a typeclasses that returns a monad.
--
--  Given a monad type class, generate the following.
--
--  - MockT instance of the given typeclass
--  - A stub function corresponding to a function of the original class type.
-- The name of stub function is the name of the original function with a "_" appended.
--
--  The prefix can be changed.
--  In that case, use `makeMockWithOptions`.
--
--  @
--  class (Monad m) => FileOperation m where
--    writeFile :: FilePath -\> Text -\> m ()
--    readFile :: FilePath -\> m Text
--
--  makeMock [t|FileOperation|]
--
--  spec :: Spec
--  spec = do
--    it "test runMockT" do
--      result \<- runMockT do
--        _readFile $ "input.txt" ~> pack "content"
--        _writeFile $ "output.text" ~> pack "content" ~> ()
--        somethingProgram
--
--      result `shouldBe` ()
--  @
makeMock :: Q Type -> Q [Dec]
makeMock :: Q Type -> Q [Dec]
makeMock Q Type
t = Q Type -> MockType -> MockOptions -> Q [Dec]
doMakeMock Q Type
t MockType
Total MockOptions
options

-- | Create a mock of a typeclasses that returns a monad.
--
--  Given a monad type class, generate the following.
--
--  - MockT instance of the given typeclass
--  - A stub function corresponding to a function of the original class type.
-- The name of stub function is the name of the original function with a "_" appended.
--
--  This function automatically wraps the return value in a monad (Implicit Monadic Return).
--
--  @
--  class (Monad m) => FileOperation m where
--    writeFile :: FilePath -\> Text -\> m ()
--    readFile :: FilePath -\> m Text
--
--  makeAutoLiftMock [t|FileOperation|]
--
--  spec :: Spec
--  spec = do
--    it "test runMockT" do
--      result \<- runMockT do
--        _readFile $ "input.txt" ~> pack "content"
--        _writeFile $ "output.text" ~> pack "content" ~> ()
--        somethingProgram
--
--      result `shouldBe` ()
--  @
makeAutoLiftMock :: Q Type -> Q [Dec]
makeAutoLiftMock :: Q Type -> Q [Dec]
makeAutoLiftMock Q Type
t = Q Type -> MockType -> MockOptions -> Q [Dec]
doMakeMock Q Type
t MockType
Total (MockOptions
options { implicitMonadicReturn = True })

-- | Create a partial mock of a typeclasses that returns a monad.
--
--  Given a monad type class, generate the following.
--
--  - MockT instance of the given typeclass
--  - A stub function corresponding to a function of the original class type.
-- The name of stub function is the name of the original function with a "_" appended.
--
--  For functions that are not stubbed in the test, the real function is used as appropriate for the context.
--
--  The prefix can be changed.
--  In that case, use `makePartialMockWithOptions`.
--
--  @
--  class Monad m => Finder a b m | a -> b, b -> a where
--    findIds :: m [a]
--    findById :: a -> m b
--
--  instance Finder Int String IO where
--    findIds = pure [1, 2, 3]
--    findById id = pure $ "{id: " <> show id <> "}"
--
--  findValue :: Finder a b m => m [b]
--  findValue = do
--    ids <- findIds
--    mapM findById ids
--
--  makePartialMock [t|Finder|]
--
--  spec :: Spec
--  spec = do
--    it "Use all real functions." do
--      values <- runMockT findValue
--      values `shouldBe` ["{id: 1}", "{id: 2}", "{id: 3}"]
--
--    it "Only findIds should be stubbed." do
--      values <- runMockT do
--        _findIds [1 :: Int, 2]
--        findValue
--      values `shouldBe` ["{id: 1}", "{id: 2}"]
--  @
makePartialMock :: Q Type -> Q [Dec]
makePartialMock :: Q Type -> Q [Dec]
makePartialMock Q Type
t = Q Type -> MockType -> MockOptions -> Q [Dec]
doMakeMock Q Type
t MockType
Partial MockOptions
options

-- | `makePartialMock` with `implicitMonadicReturn = True` by default.
makeAutoLiftPartialMock :: Q Type -> Q [Dec]
makeAutoLiftPartialMock :: Q Type -> Q [Dec]
makeAutoLiftPartialMock Q Type
t = Q Type -> MockType -> MockOptions -> Q [Dec]
doMakeMock Q Type
t MockType
Partial (MockOptions
options { implicitMonadicReturn = True })



doMakeMock :: Q Type -> MockType -> MockOptions -> Q [Dec]
doMakeMock :: Q Type -> MockType -> MockOptions -> Q [Dec]
doMakeMock Q Type
qType MockType
mockType MockOptions
options = do
  Q ()
verifyRequiredExtensions
  Type
ty <- Q Type
qType
  let className :: Name
className = Type -> Name
getClassName Type
ty
  ClassMetadata
classMetadata <- Name -> Q ClassMetadata
loadClassMetadata Name
className
  Name
monadVarName <- ClassMetadata -> Q Name
selectMonadVarName ClassMetadata
classMetadata
  Type
-> MockType
-> Name
-> Name
-> Cxt
-> [TyVarBndr ()]
-> [Dec]
-> MockOptions
-> Q [Dec]
forall a.
Type
-> MockType
-> Name
-> Name
-> Cxt
-> [TyVarBndr a]
-> [Dec]
-> MockOptions
-> Q [Dec]
makeMockDecs
    Type
ty
    MockType
mockType
    Name
className
    Name
monadVarName
    (ClassMetadata -> Cxt
cmContext ClassMetadata
classMetadata)
    (ClassMetadata -> [TyVarBndr ()]
cmTypeVars ClassMetadata
classMetadata)
    (ClassMetadata -> [Dec]
cmDecs ClassMetadata
classMetadata)
    MockOptions
options

verifyRequiredExtensions :: Q ()
verifyRequiredExtensions :: Q ()
verifyRequiredExtensions =
  (Extension -> Q ()) -> [Extension] -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    Extension -> Q ()
verifyExtension
    [Extension
DataKinds, Extension
FlexibleInstances, Extension
FlexibleContexts, Extension
TypeFamilies]

loadClassMetadata :: Name -> Q ClassMetadata
loadClassMetadata :: Name -> Q ClassMetadata
loadClassMetadata Name
className = do
  Info
info <- Name -> Q Info
reify Name
className
  case Info
info of
    ClassI (ClassD Cxt
_ Name
_ [] [FunDep]
_ [Dec]
_) [Dec]
_ ->
      String -> Q ClassMetadata
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ClassMetadata) -> String -> Q ClassMetadata
forall a b. (a -> b) -> a -> b
$ String
"A type parameter is required for class " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
className
    ClassI (ClassD Cxt
cxt Name
_ [TyVarBndr BndrVis]
typeVars [FunDep]
_ [Dec]
decs) [Dec]
_ ->
      ClassMetadata -> Q ClassMetadata
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClassMetadata -> Q ClassMetadata)
-> ClassMetadata -> Q ClassMetadata
forall a b. (a -> b) -> a -> b
$
        ClassMetadata
          { cmName :: Name
cmName = Name
className,
            cmContext :: Cxt
cmContext = Cxt
cxt,
            cmTypeVars :: [TyVarBndr ()]
cmTypeVars = (TyVarBndr BndrVis -> TyVarBndr ())
-> [TyVarBndr BndrVis] -> [TyVarBndr ()]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> TyVarBndr ()
forall a. TyVarBndr a -> TyVarBndr ()
convertTyVarBndr [TyVarBndr BndrVis]
typeVars,
            cmDecs :: [Dec]
cmDecs = [Dec]
decs
          }
    Info
other -> String -> Q ClassMetadata
forall a. HasCallStack => String -> a
error (String -> Q ClassMetadata) -> String -> Q ClassMetadata
forall a b. (a -> b) -> a -> b
$ String
"unsupported type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Info -> String
forall a. Show a => a -> String
show Info
other

selectMonadVarName :: ClassMetadata -> Q Name
selectMonadVarName :: ClassMetadata -> Q Name
selectMonadVarName ClassMetadata
metadata = do
  [Name]
monadVarNames <- Cxt -> [TyVarBndr ()] -> Q [Name]
forall a. Cxt -> [TyVarBndr a] -> Q [Name]
getMonadVarNames (ClassMetadata -> Cxt
cmContext ClassMetadata
metadata) (ClassMetadata -> [TyVarBndr ()]
cmTypeVars ClassMetadata
metadata)
  case [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub [Name]
monadVarNames of
    [] -> String -> Q Name
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Monad parameter not found."
    (Name
monadVarName : [Name]
rest)
      | [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
rest Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 -> String -> Q Name
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Monad parameter must be unique."
      | Bool
otherwise -> Name -> Q Name
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
monadVarName

makeMockDecs :: Type -> MockType -> Name -> Name -> Cxt -> [TyVarBndr a] -> [Dec] -> MockOptions -> Q [Dec]
makeMockDecs :: forall a.
Type
-> MockType
-> Name
-> Name
-> Cxt
-> [TyVarBndr a]
-> [Dec]
-> MockOptions
-> Q [Dec]
makeMockDecs Type
ty MockType
mockType Name
className Name
monadVarName Cxt
cxt [TyVarBndr a]
typeVars [Dec]
decs MockOptions
options = do
  let classParamNames :: [Name]
classParamNames = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name
className Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/=) (Type -> [Name]
getClassNames Type
ty)
      newTypeVars :: [TyVarBndr a]
newTypeVars = Int -> [TyVarBndr a] -> [TyVarBndr a]
forall a. Int -> [a] -> [a]
drop ([Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
classParamNames) [TyVarBndr a]
typeVars
      varAppliedTypes :: [VarAppliedType]
varAppliedTypes = (Name -> Int -> VarAppliedType)
-> [Name] -> [Int] -> [VarAppliedType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
t Int
i -> Name -> Maybe Name -> VarAppliedType
VarAppliedType Name
t ([Name] -> Int -> Maybe Name
forall a. [a] -> Int -> Maybe a
safeIndex [Name]
classParamNames Int
i)) ([TyVarBndr a] -> [Name]
forall a. [TyVarBndr a] -> [Name]
getTypeVarNames [TyVarBndr a]
typeVars) [Int
0 ..]
      sigDecs :: [Dec]
sigDecs = [Dec
dec | dec :: Dec
dec@(SigD Name
_ Type
_) <- [Dec]
decs]
      typeFamilyHeads :: [TypeFamilyHead]
typeFamilyHeads =
        [TypeFamilyHead
head | OpenTypeFamilyD TypeFamilyHead
head <- [Dec]
decs] [TypeFamilyHead] -> [TypeFamilyHead] -> [TypeFamilyHead]
forall a. [a] -> [a] -> [a]
++
        [TypeFamilyHead
head | ClosedTypeFamilyD TypeFamilyHead
head [TySynEqn]
_ <- [Dec]
decs]

  let typeInstDecs :: [Q Dec]
typeInstDecs = (TypeFamilyHead -> Q Dec) -> [TypeFamilyHead] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> TypeFamilyHead -> Q Dec
createTypeInstanceDec Name
monadVarName) [TypeFamilyHead]
typeFamilyHeads
      instanceBodyDecs :: [Q Dec]
instanceBodyDecs = (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map (MockType -> MockOptions -> Dec -> Q Dec
createInstanceFnDec MockType
mockType MockOptions
options) [Dec]
sigDecs [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++ [Q Dec]
typeInstDecs
      fullCxt :: Cxt
fullCxt = Cxt
-> MockType
-> Name
-> Name
-> [TyVarBndr a]
-> [VarAppliedType]
-> Cxt
forall a.
Cxt
-> MockType
-> Name
-> Name
-> [TyVarBndr a]
-> [VarAppliedType]
-> Cxt
buildContext Cxt
cxt MockType
mockType Name
className Name
monadVarName [TyVarBndr a]
newTypeVars [VarAppliedType]
varAppliedTypes
  ([Dec]
superClassDecs, Cxt
predsToDrop) <-
    MockType
-> Name
-> [TyVarBndr a]
-> [VarAppliedType]
-> MockOptions
-> Cxt
-> Q ([Dec], Cxt)
forall a.
MockType
-> Name
-> [TyVarBndr a]
-> [VarAppliedType]
-> MockOptions
-> Cxt
-> Q ([Dec], Cxt)
deriveSuperClassInstances
      MockType
mockType
      Name
monadVarName
      [TyVarBndr a]
newTypeVars
      [VarAppliedType]
varAppliedTypes
      MockOptions
options
      Cxt
cxt
  let filteredCxt :: Cxt
filteredCxt = (Type -> Bool) -> Cxt -> Cxt
forall a. (a -> Bool) -> [a] -> [a]
filter (Type -> Cxt -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Cxt
predsToDrop) Cxt
fullCxt
  Dec
instanceDec <-
    Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
      (Cxt -> Q Cxt
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
filteredCxt)
      (Type -> Name -> [TyVarBndr a] -> Q Type
forall a. Type -> Name -> [TyVarBndr a] -> Q Type
createInstanceType Type
ty Name
monadVarName [TyVarBndr a]
newTypeVars)
      [Q Dec]
instanceBodyDecs
  [Dec]
mockFnDecs <- [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dec -> Q [Dec]) -> [Dec] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (MockType
-> Name -> [VarAppliedType] -> MockOptions -> Dec -> Q [Dec]
mockDec MockType
mockType Name
monadVarName [VarAppliedType]
varAppliedTypes MockOptions
options) [Dec]
sigDecs

  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
superClassDecs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ (Dec
instanceDec Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
mockFnDecs)

deriveSuperClassInstances ::
  MockType ->
  Name ->
  [TyVarBndr a] ->
  [VarAppliedType] ->
  MockOptions ->
  Cxt ->
  Q ([Dec], [Pred])
deriveSuperClassInstances :: forall a.
MockType
-> Name
-> [TyVarBndr a]
-> [VarAppliedType]
-> MockOptions
-> Cxt
-> Q ([Dec], Cxt)
deriveSuperClassInstances MockType
mockType Name
_ [TyVarBndr a]
_ [VarAppliedType]
_ MockOptions
_ Cxt
_
  | MockType
mockType MockType -> MockType -> Bool
forall a. Eq a => a -> a -> Bool
/= MockType
Total = ([Dec], Cxt) -> Q ([Dec], Cxt)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
deriveSuperClassInstances MockType
_ Name
monadVarName [TyVarBndr a]
typeVars [VarAppliedType]
varAppliedTypes MockOptions
_ Cxt
cxt = do
  [Maybe (Dec, Type)]
results <- (Type -> Q (Maybe (Dec, Type))) -> Cxt -> Q [Maybe (Dec, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name
-> [TyVarBndr a]
-> [VarAppliedType]
-> Type
-> Q (Maybe (Dec, Type))
forall a.
Name
-> [TyVarBndr a]
-> [VarAppliedType]
-> Type
-> Q (Maybe (Dec, Type))
deriveSuperClassInstance Name
monadVarName [TyVarBndr a]
typeVars [VarAppliedType]
varAppliedTypes) Cxt
cxt
  let valid :: [(Dec, Type)]
valid = [Maybe (Dec, Type)] -> [(Dec, Type)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Dec, Type)]
results
  ([Dec], Cxt) -> Q ([Dec], Cxt)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Dec, Type) -> Dec) -> [(Dec, Type)] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map (Dec, Type) -> Dec
forall a b. (a, b) -> a
fst [(Dec, Type)]
valid, ((Dec, Type) -> Type) -> [(Dec, Type)] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Dec, Type) -> Type
forall a b. (a, b) -> b
snd [(Dec, Type)]
valid)

deriveSuperClassInstance ::
  Name ->
  [TyVarBndr a] ->
  [VarAppliedType] ->
  Pred ->
  Q (Maybe (Dec, Pred))
deriveSuperClassInstance :: forall a.
Name
-> [TyVarBndr a]
-> [VarAppliedType]
-> Type
-> Q (Maybe (Dec, Type))
deriveSuperClassInstance Name
_ [TyVarBndr a]
_ [VarAppliedType]
varAppliedTypes Type
pred = do
  Maybe SuperClassInfo
superInfo <- Type -> Q (Maybe SuperClassInfo)
resolveSuperClassInfo Type
pred
  Q (Maybe (Dec, Type))
-> (SuperClassInfo -> Q (Maybe (Dec, Type)))
-> Maybe SuperClassInfo
-> Q (Maybe (Dec, Type))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (Dec, Type) -> Q (Maybe (Dec, Type))
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Dec, Type)
forall a. Maybe a
Nothing) ([VarAppliedType] -> SuperClassInfo -> Q (Maybe (Dec, Type))
buildSuperClassDerivation [VarAppliedType]
varAppliedTypes) Maybe SuperClassInfo
superInfo
  where
    resolveSuperClassInfo :: Pred -> Q (Maybe SuperClassInfo)
    resolveSuperClassInfo :: Type -> Q (Maybe SuperClassInfo)
resolveSuperClassInfo Type
target =
      case Type -> (Type, Cxt)
splitApps Type
target of
        (ConT Name
superName, Cxt
args) -> do
          Info
info <- Name -> Q Info
reify Name
superName
          Maybe SuperClassInfo -> Q (Maybe SuperClassInfo)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe SuperClassInfo -> Q (Maybe SuperClassInfo))
-> Maybe SuperClassInfo -> Q (Maybe SuperClassInfo)
forall a b. (a -> b) -> a -> b
$
            case Info
info of
              ClassI (ClassD Cxt
superCxt Name
_ [TyVarBndr BndrVis]
superTypeVars [FunDep]
_ [Dec]
superDecs) [Dec]
_ ->
                SuperClassInfo -> Maybe SuperClassInfo
forall a. a -> Maybe a
Just (SuperClassInfo -> Maybe SuperClassInfo)
-> SuperClassInfo -> Maybe SuperClassInfo
forall a b. (a -> b) -> a -> b
$ Name -> Cxt -> Cxt -> [TyVarBndr ()] -> [Dec] -> SuperClassInfo
SuperClassInfo Name
superName Cxt
args Cxt
superCxt ((TyVarBndr BndrVis -> TyVarBndr ())
-> [TyVarBndr BndrVis] -> [TyVarBndr ()]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> TyVarBndr ()
forall a. TyVarBndr a -> TyVarBndr ()
convertTyVarBndr [TyVarBndr BndrVis]
superTypeVars) [Dec]
superDecs
              Info
_ -> Maybe SuperClassInfo
forall a. Maybe a
Nothing
        (Type, Cxt)
_ -> Maybe SuperClassInfo -> Q (Maybe SuperClassInfo)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SuperClassInfo
forall a. Maybe a
Nothing

    buildSuperClassDerivation ::
      [VarAppliedType] ->
      SuperClassInfo ->
      Q (Maybe (Dec, Pred))
    buildSuperClassDerivation :: [VarAppliedType] -> SuperClassInfo -> Q (Maybe (Dec, Type))
buildSuperClassDerivation [VarAppliedType]
appliedTypes SuperClassInfo
info
      | SuperClassInfo -> Bool
superClassHasMethods SuperClassInfo
info = Maybe (Dec, Type) -> Q (Maybe (Dec, Type))
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Dec, Type)
forall a. Maybe a
Nothing
      | Bool
otherwise = do
          [Name]
superMonadVars <- Cxt -> [TyVarBndr ()] -> Q [Name]
forall a. Cxt -> [TyVarBndr a] -> Q [Name]
getMonadVarNames (SuperClassInfo -> Cxt
scContext SuperClassInfo
info) (SuperClassInfo -> [TyVarBndr ()]
scTypeVars SuperClassInfo
info)
          case [Name]
superMonadVars of
            [Name
superMonadVar] -> [VarAppliedType] -> SuperClassInfo -> Name -> Q (Maybe (Dec, Type))
buildMockInstance [VarAppliedType]
appliedTypes SuperClassInfo
info Name
superMonadVar
            [Name]
_ -> Maybe (Dec, Type) -> Q (Maybe (Dec, Type))
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Dec, Type)
forall a. Maybe a
Nothing

    buildMockInstance ::
      [VarAppliedType] ->
      SuperClassInfo ->
      Name ->
      Q (Maybe (Dec, Pred))
    buildMockInstance :: [VarAppliedType] -> SuperClassInfo -> Name -> Q (Maybe (Dec, Type))
buildMockInstance [VarAppliedType]
appliedTypes SuperClassInfo
info Name
superMonadVar = do
      let superVarNames :: [Name]
superVarNames = (TyVarBndr () -> Name) -> [TyVarBndr ()] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
getTypeVarName (SuperClassInfo -> [TyVarBndr ()]
scTypeVars SuperClassInfo
info)
      if [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
superVarNames Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Cxt -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (SuperClassInfo -> Cxt
scArgs SuperClassInfo
info)
        then Maybe (Dec, Type) -> Q (Maybe (Dec, Type))
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Dec, Type)
forall a. Maybe a
Nothing
        else do
          let (Cxt
contextPreds, Type
instanceType) =
                [VarAppliedType] -> SuperClassInfo -> Name -> [Name] -> (Cxt, Type)
buildInstancePieces [VarAppliedType]
appliedTypes SuperClassInfo
info Name
superMonadVar [Name]
superVarNames
          Dec
instanceDec <- Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (Cxt -> Q Cxt
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
contextPreds) (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
instanceType) []
          Maybe (Dec, Type) -> Q (Maybe (Dec, Type))
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Dec, Type) -> Q (Maybe (Dec, Type)))
-> Maybe (Dec, Type) -> Q (Maybe (Dec, Type))
forall a b. (a -> b) -> a -> b
$ (Dec, Type) -> Maybe (Dec, Type)
forall a. a -> Maybe a
Just (Dec
instanceDec, Type
instanceType)

    buildInstancePieces ::
      [VarAppliedType] ->
      SuperClassInfo ->
      Name ->
      [Name] ->
      ([Pred], Pred)
    buildInstancePieces :: [VarAppliedType] -> SuperClassInfo -> Name -> [Name] -> (Cxt, Type)
buildInstancePieces [VarAppliedType]
appliedTypes SuperClassInfo
info Name
superMonadVar [Name]
superVarNames =
      let substitutedArgs :: Cxt
substitutedArgs = (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([VarAppliedType] -> Type -> Type
applyVarAppliedTypes [VarAppliedType]
appliedTypes) (SuperClassInfo -> Cxt
scArgs SuperClassInfo
info)
          subMap :: Map Name Type
subMap = [(Name, Type)] -> Map Name Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Name] -> Cxt -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
superVarNames Cxt
substitutedArgs)
          instanceArgs :: Cxt
instanceArgs =
            (Name -> Type) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map
              ([VarAppliedType] -> Name -> Map Name Type -> Name -> Type
buildInstanceArg [VarAppliedType]
appliedTypes Name
superMonadVar Map Name Type
subMap)
              [Name]
superVarNames
          instanceType :: Type
instanceType = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (SuperClassInfo -> Name
scName SuperClassInfo
info)) Cxt
instanceArgs
          contextPreds :: Cxt
contextPreds =
            (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map
              ([VarAppliedType] -> Type -> Type
applyVarAppliedTypes [VarAppliedType]
appliedTypes (Type -> Type) -> (Type -> Type) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name Type -> Type -> Type
substituteType Map Name Type
subMap)
              (SuperClassInfo -> Cxt
scContext SuperClassInfo
info)
       in (Cxt
contextPreds, Type
instanceType)

    buildInstanceArg ::
      [VarAppliedType] ->
      Name ->
      Map.Map Name Type ->
      Name ->
      Type
    buildInstanceArg :: [VarAppliedType] -> Name -> Map Name Type -> Name -> Type
buildInstanceArg [VarAppliedType]
appliedTypes Name
superMonadVar Map Name Type
subMap Name
var =
      let applied :: Type
applied = [VarAppliedType] -> Type -> Type
applyVarAppliedTypes [VarAppliedType]
appliedTypes (Map Name Type -> Name -> Type
lookupType Map Name Type
subMap Name
var)
       in if Name
var Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
superMonadVar
            then Type -> Type -> Type
AppT (Name -> Type
ConT ''MockT) Type
applied
            else Type
applied

    lookupType :: Map.Map Name Type -> Name -> Type
    lookupType :: Map Name Type -> Name -> Type
lookupType Map Name Type
subMap Name
key = Type -> Name -> Map Name Type -> Type
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (Name -> Type
VarT Name
key) Name
key Map Name Type
subMap

    superClassHasMethods :: SuperClassInfo -> Bool
    superClassHasMethods :: SuperClassInfo -> Bool
superClassHasMethods = (Dec -> Bool) -> [Dec] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
P.any Dec -> Bool
isSignature ([Dec] -> Bool)
-> (SuperClassInfo -> [Dec]) -> SuperClassInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SuperClassInfo -> [Dec]
scDecs

    isSignature :: Dec -> Bool
isSignature (SigD Name
_ Type
_) = Bool
True
    isSignature Dec
_ = Bool
False


data SuperClassInfo = SuperClassInfo
  { SuperClassInfo -> Name
scName :: Name,
    SuperClassInfo -> Cxt
scArgs :: [Type],
    SuperClassInfo -> Cxt
scContext :: Cxt,
    SuperClassInfo -> [TyVarBndr ()]
scTypeVars :: [TyVarBndr ()],
    SuperClassInfo -> [Dec]
scDecs :: [Dec]
  }

data ClassMetadata = ClassMetadata
  { ClassMetadata -> Name
cmName :: Name,
    ClassMetadata -> Cxt
cmContext :: Cxt,
    ClassMetadata -> [TyVarBndr ()]
cmTypeVars :: [TyVarBndr ()],
    ClassMetadata -> [Dec]
cmDecs :: [Dec]
  }

getMonadVarNames :: Cxt -> [TyVarBndr a] -> Q [Name]
getMonadVarNames :: forall a. Cxt -> [TyVarBndr a] -> Q [Name]
getMonadVarNames Cxt
cxt [TyVarBndr a]
typeVars = do
  let parentClassInfos :: [ClassName2VarNames]
parentClassInfos = Cxt -> [ClassName2VarNames]
toClassInfos Cxt
cxt

      typeVarNames :: [Name]
typeVarNames = [TyVarBndr a] -> [Name]
forall a. [TyVarBndr a] -> [Name]
getTypeVarNames [TyVarBndr a]
typeVars
      -- VarInfos (class names is empty)
      emptyClassVarInfos :: [VarName2ClassNames]
emptyClassVarInfos = (Name -> VarName2ClassNames) -> [Name] -> [VarName2ClassNames]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> [Name] -> VarName2ClassNames
`VarName2ClassNames` []) [Name]
typeVarNames

  [VarName2ClassNames]
varInfos <- [ClassName2VarNames]
-> [VarName2ClassNames] -> Q [VarName2ClassNames]
collectVarInfos [ClassName2VarNames]
parentClassInfos [VarName2ClassNames]
emptyClassVarInfos

  [Name] -> Q [Name]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Name] -> Q [Name]) -> [Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ (\(VarName2ClassNames Name
n [Name]
_) -> Name
n) (VarName2ClassNames -> Name) -> [VarName2ClassNames] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarName2ClassNames] -> [VarName2ClassNames]
filterMonadicVarInfos [VarName2ClassNames]
varInfos

collectVarInfos :: [ClassName2VarNames] -> [VarName2ClassNames] -> Q [VarName2ClassNames]
collectVarInfos :: [ClassName2VarNames]
-> [VarName2ClassNames] -> Q [VarName2ClassNames]
collectVarInfos [ClassName2VarNames]
classInfos = (VarName2ClassNames -> Q VarName2ClassNames)
-> [VarName2ClassNames] -> Q [VarName2ClassNames]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([ClassName2VarNames] -> VarName2ClassNames -> Q VarName2ClassNames
collectVarInfo [ClassName2VarNames]
classInfos)

collectVarInfo :: [ClassName2VarNames] -> VarName2ClassNames -> Q VarName2ClassNames
collectVarInfo :: [ClassName2VarNames] -> VarName2ClassNames -> Q VarName2ClassNames
collectVarInfo [ClassName2VarNames]
classInfos (VarName2ClassNames Name
vName [Name]
classNames) = do
  [Name]
varClassNames <- Name -> [ClassName2VarNames] -> Q [Name]
collectVarClassNames Name
vName [ClassName2VarNames]
classInfos
  VarName2ClassNames -> Q VarName2ClassNames
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarName2ClassNames -> Q VarName2ClassNames)
-> VarName2ClassNames -> Q VarName2ClassNames
forall a b. (a -> b) -> a -> b
$ Name -> [Name] -> VarName2ClassNames
VarName2ClassNames Name
vName ([Name]
classNames [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
varClassNames)

collectVarClassNames :: Name -> [ClassName2VarNames] -> Q [Name]
collectVarClassNames :: Name -> [ClassName2VarNames] -> Q [Name]
collectVarClassNames Name
varName [ClassName2VarNames]
classInfos = do
  let targetClassInfos :: [ClassName2VarNames]
targetClassInfos = Name -> [ClassName2VarNames] -> [ClassName2VarNames]
filterClassInfo Name
varName [ClassName2VarNames]
classInfos
  [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Name]] -> [Name]) -> Q [[Name]] -> Q [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ClassName2VarNames -> Q [Name])
-> [ClassName2VarNames] -> Q [[Name]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name -> ClassName2VarNames -> Q [Name]
collectVarClassNames_ Name
varName) [ClassName2VarNames]
targetClassInfos

collectVarClassNames_ :: Name -> ClassName2VarNames -> Q [Name]
collectVarClassNames_ :: Name -> ClassName2VarNames -> Q [Name]
collectVarClassNames_ Name
name (ClassName2VarNames Name
cName [Name]
vNames) = do
  case Name -> [Name] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Name
name [Name]
vNames of
    Maybe Int
Nothing -> [Name] -> Q [Name]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Just Int
i -> do
      ClassI (ClassD Cxt
cxt Name
_ [TyVarBndr BndrVis]
typeVars [FunDep]
_ [Dec]
_) [Dec]
_ <- Name -> Q Info
reify Name
cName
      let -- type variable names
          typeVarNames :: [Name]
typeVarNames = [TyVarBndr BndrVis] -> [Name]
forall a. [TyVarBndr a] -> [Name]
getTypeVarNames [TyVarBndr BndrVis]
typeVars
          -- type variable name of same position
          typeVarName :: Name
typeVarName = [Name]
typeVarNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
          -- parent class information
          parentClassInfos :: [ClassName2VarNames]
parentClassInfos = Cxt -> [ClassName2VarNames]
toClassInfos Cxt
cxt

      case [ClassName2VarNames]
parentClassInfos of
        [] -> [Name] -> Q [Name]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Name
cName]
        [ClassName2VarNames]
_ -> do
          [Name]
result <- [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Name]] -> [Name]) -> Q [[Name]] -> Q [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ClassName2VarNames -> Q [Name])
-> [ClassName2VarNames] -> Q [[Name]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name -> ClassName2VarNames -> Q [Name]
collectVarClassNames_ Name
typeVarName) [ClassName2VarNames]
parentClassInfos
          [Name] -> Q [Name]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Name] -> Q [Name]) -> [Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Name
cName Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
result

createInstanceType :: Type -> Name -> [TyVarBndr a] -> Q Type
createInstanceType :: forall a. Type -> Name -> [TyVarBndr a] -> Q Type
createInstanceType Type
className Name
monadName [TyVarBndr a]
tvbs = do
  let types :: Cxt
types = (TyVarBndr a -> Type) -> [TyVarBndr a] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> TyVarBndr a -> Type
forall a. Name -> TyVarBndr a -> Type
tyVarBndrToType Name
monadName) [TyVarBndr a]
tvbs
  Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> Cxt -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
className Cxt
types

createTypeInstanceDec :: Name -> TypeFamilyHead -> Q Dec
createTypeInstanceDec :: Name -> TypeFamilyHead -> Q Dec
createTypeInstanceDec Name
monadVarName (TypeFamilyHead Name
familyName [TyVarBndr BndrVis]
tfVars FamilyResultSig
_ Maybe InjectivityAnn
_) = do
  let lhsArgs :: Cxt
lhsArgs = (TyVarBndr BndrVis -> Type) -> [TyVarBndr BndrVis] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Name -> TyVarBndr BndrVis -> Type
forall a. Name -> TyVarBndr a -> Type
applyFamilyArg Name
monadVarName) [TyVarBndr BndrVis]
tfVars
      rhsArgs :: Cxt
rhsArgs = (TyVarBndr BndrVis -> Type) -> [TyVarBndr BndrVis] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type)
-> (TyVarBndr BndrVis -> Name) -> TyVarBndr BndrVis -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr BndrVis -> Name
forall a. TyVarBndr a -> Name
getTypeVarName) [TyVarBndr BndrVis]
tfVars
      lhsType :: Type
lhsType = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
familyName) Cxt
lhsArgs
      rhsType :: Type
rhsType = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
familyName) Cxt
rhsArgs
  Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ TySynEqn -> Dec
TySynInstD (Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr ()]
forall a. Maybe a
Nothing Type
lhsType Type
rhsType)

createInstanceFnDec :: MockType -> MockOptions -> Dec -> Q Dec
createInstanceFnDec :: MockType -> MockOptions -> Dec -> Q Dec
createInstanceFnDec MockType
mockType MockOptions
options (SigD Name
fnName Type
funType) = do
  [Name]
names <- [Q Name] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Q Name] -> Q [Name]) -> [Q Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Type -> [Q Name]
typeToNames Type
funType
  let r :: Name
r = String -> Name
mkName String
"result"
      params :: [Q Pat]
params = Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> Q Pat) -> [Name] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
names
      args :: [Q Exp]
args = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> [Name] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
names
      fnNameStr :: String
fnNameStr = Name -> MockOptions -> String
createFnName Name
fnName MockOptions
options

      fnBody :: Q Exp
fnBody = case MockType
mockType of
        MockType
Total -> String -> [Q Exp] -> Name -> MockOptions -> Q Exp
generateInstanceMockFnBody String
fnNameStr [Q Exp]
args Name
r MockOptions
options
        MockType
Partial -> Name -> String -> [Q Exp] -> Name -> MockOptions -> Q Exp
generateInstanceRealFnBody Name
fnName String
fnNameStr [Q Exp]
args Name
r MockOptions
options

      fnClause :: Q Clause
fnClause = [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat]
params (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
fnBody) []
  Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
fnName [Q Clause
fnClause]
createInstanceFnDec MockType
_ MockOptions
_ Dec
dec = String -> Q Dec
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Dec) -> String -> Q Dec
forall a b. (a -> b) -> a -> b
$ String
"unsuported dec: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Dec -> String
forall a. Ppr a => a -> String
pprint Dec
dec



mockDec :: MockType -> Name -> [VarAppliedType] -> MockOptions -> Dec -> Q [Dec]
mockDec :: MockType
-> Name -> [VarAppliedType] -> MockOptions -> Dec -> Q [Dec]
mockDec MockType
mockType Name
monadVarName [VarAppliedType]
varAppliedTypes MockOptions
options (SigD Name
sigFnName Type
ty) = do
  let ctx :: MockFnContext
ctx = MockType
-> Name
-> [VarAppliedType]
-> MockOptions
-> Name
-> Type
-> MockFnContext
buildMockFnContext MockType
mockType Name
monadVarName [VarAppliedType]
varAppliedTypes MockOptions
options Name
sigFnName Type
ty
  [Dec]
fnDecs <- MockFnContext -> Q [Dec]
buildMockFnDeclarations MockFnContext
ctx
  Dec
pragmaDec <- Name -> Q Dec
createNoInlinePragma (MockFnContext -> Name
mockFnName MockFnContext
ctx)
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
pragmaDec Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
fnDecs
mockDec MockType
_ Name
_ [VarAppliedType]
_ MockOptions
_ Dec
dec = String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String
"unsupport dec: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Dec -> String
forall a. Ppr a => a -> String
pprint Dec
dec



verifyExtension :: Extension -> Q ()
verifyExtension :: Extension -> Q ()
verifyExtension Extension
e = Extension -> Q Bool
isExtEnabled Extension
e Q Bool -> (Bool -> Q ()) -> Q ()
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> Q () -> Q ()) -> Q () -> Bool -> Q ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Language extensions `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Extension -> String
forall a. Show a => a -> String
show Extension
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"` is required.")