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

module Test.MockCat.TH (showExp, expectByExpr, makeMock, makeMockWithOptions, MockOptions(..), options) where

import Language.Haskell.TH
    ( Exp(..),
      Lit(..),
      Pat(..),
      Q,
      pprint,
      Name,
      Dec(..),
      Info(..),
      reify,
      mkName,
      Type(..),
      Quote(newName),
      Cxt,
      TyVarBndr(..),
      Pred,
      isExtEnabled,
      Extension(..) )
import Language.Haskell.TH.PprLib (Doc, hcat, parens, text)
import Language.Haskell.TH.Syntax (nameBase)
import Test.MockCat.Param (Param(..))
import Test.MockCat.Cons ((:>))
import Test.MockCat.MockT
import Data.Data (Proxy(..))
import Data.List (find, nub, elemIndex)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Unsafe.Coerce (unsafeCoerce)
import Control.Monad.State (modify, get)
import Data.Maybe (fromMaybe, isJust)
import GHC.IO (unsafePerformIO)
import Language.Haskell.TH.Lib
import Data.Text (splitOn, unpack, pack)
import Test.MockCat.Mock (MockBuilder)
import Control.Monad (guard, unless)
import Data.Function ((&))

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 applying 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|]

{- | Options for generating mocks. 

  - prefix: Stub function prefix
  - suffix: stub function suffix
-}
data MockOptions = MockOptions { MockOptions -> String
prefix :: String, MockOptions -> String
suffix :: String }

{- | Default Options.

  Stub function names are prefixed with “_”.
-}
options :: MockOptions
options :: MockOptions
options = MockOptions { prefix :: String
prefix = String
"_", suffix :: String
suffix = String
"" }

{- | Create a mock of the typeclasses that returns a monad according to the `MockOptions`. 

  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.

  @
  class (Monad m) => FileOperation m where
    writeFile :: FilePath -\> Text -\> m ()
    readFile :: FilePath -\> m Text

  makeMockWithOptions [t|FileOperation|] options { prefix = "stub_" }

  it "test runMockT" do
    result \<- runMockT do
      stub_readFile $ "input.txt" |\> pack "content"
      stub_writeFile $ "output.text" |\> pack "content" |\> ()
      somethingProgram

    result `shouldBe` ()
  @

-}
makeMockWithOptions :: Q Type -> MockOptions -> Q [Dec]
makeMockWithOptions :: Q Type -> MockOptions -> Q [Dec]
makeMockWithOptions = Q Type -> MockOptions -> Q [Dec]
doMakeMock

{- | 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|]

  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 -> MockOptions -> Q [Dec])
-> MockOptions -> Q Type -> Q [Dec]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Q Type -> MockOptions -> Q [Dec]
doMakeMock MockOptions
options

doMakeMock :: Q Type -> MockOptions -> Q [Dec]
doMakeMock :: Q Type -> MockOptions -> Q [Dec]
doMakeMock Q Type
t MockOptions
options = do
  Extension -> Q ()
verifyExtension Extension
DataKinds
  Extension -> Q ()
verifyExtension Extension
FlexibleInstances
  Extension -> Q ()
verifyExtension Extension
FlexibleContexts

  Type
ty <- Q Type
t
  Name
className <- Type -> Name
getClassName (Type -> Name) -> Q Type -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Type
t

  Name -> Q Info
reify Name
className Q Info -> (Info -> Q [Dec]) -> Q [Dec]
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
_ Name
_ [] [FunDep]
_ [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
"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 ()]
typeVars [FunDep]
_ [Dec]
decs) [Dec]
_ -> do
      [Name]
monadVarNames <- Cxt -> [TyVarBndr ()] -> Q [Name]
forall a. Cxt -> [TyVarBndr a] -> Q [Name]
getMonadVarNames Cxt
cxt [TyVarBndr ()]
typeVars
      case [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub [Name]
monadVarNames of
        [] -> String -> Q [Dec]
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 [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Monad parameter must be unique."
          | Bool
otherwise -> Type
-> Name
-> Name
-> Cxt
-> [TyVarBndr ()]
-> [Dec]
-> MockOptions
-> Q [Dec]
forall a.
Type
-> Name
-> Name
-> Cxt
-> [TyVarBndr a]
-> [Dec]
-> MockOptions
-> Q [Dec]
makeMockDecs Type
ty Name
className Name
monadVarName Cxt
cxt [TyVarBndr ()]
typeVars [Dec]
decs MockOptions
options

    Info
t -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error (String -> Q [Dec]) -> String -> Q [Dec]
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
t


makeMockDecs :: Type -> Name -> Name -> Cxt -> [TyVarBndr a] -> [Dec] -> MockOptions -> Q [Dec]
makeMockDecs :: forall a.
Type
-> Name
-> Name
-> Cxt
-> [TyVarBndr a]
-> [Dec]
-> MockOptions
-> Q [Dec]
makeMockDecs Type
ty 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..]

  Cxt
newCxt <- Name -> Cxt -> Q Cxt
createCxt Name
monadVarName Cxt
cxt
  Type
m <- Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Monad) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
monadVarName)

  let hasMonad :: Bool
hasMonad = (ClassName2VarNames -> Bool) -> [ClassName2VarNames] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(ClassName2VarNames Name
c [Name]
_) -> Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Monad) ([ClassName2VarNames] -> Bool) -> [ClassName2VarNames] -> Bool
forall a b. (a -> b) -> a -> b
$ Cxt -> [ClassName2VarNames]
toClassInfos Cxt
newCxt

  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 -> Q Cxt) -> Cxt -> Q Cxt
forall a b. (a -> b) -> a -> b
$ Cxt
newCxt Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ ([Type
m | Bool -> Bool
not Bool
hasMonad]))
    (Type -> Name -> [TyVarBndr a] -> Q Type
forall a. Type -> Name -> [TyVarBndr a] -> Q Type
createInstanceType Type
ty Name
monadVarName [TyVarBndr a]
newTypeVars)
    ((Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map (MockOptions -> Dec -> Q Dec
createInstanceFnDec MockOptions
options) [Dec]
decs)

  [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 (Name -> [VarAppliedType] -> MockOptions -> Dec -> Q [Dec]
createMockFnDec Name
monadVarName [VarAppliedType]
varAppliedTypes MockOptions
options) [Dec]
decs

  [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
instanceDec Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
mockFnDecs

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

getTypeVarNames :: [TyVarBndr a] -> [Name]
getTypeVarNames :: forall a. [TyVarBndr a] -> [Name]
getTypeVarNames = (TyVarBndr a -> Name) -> [TyVarBndr a] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr a -> Name
forall a. TyVarBndr a -> Name
getTypeVarName

getTypeVarName :: TyVarBndr a -> Name
getTypeVarName :: forall a. TyVarBndr a -> Name
getTypeVarName (PlainTV Name
name a
_) = Name
name
getTypeVarName (KindedTV Name
name a
_ Type
_) = Name
name

toClassInfos :: Cxt -> [ClassName2VarNames]
toClassInfos :: Cxt -> [ClassName2VarNames]
toClassInfos = (Type -> ClassName2VarNames) -> Cxt -> [ClassName2VarNames]
forall a b. (a -> b) -> [a] -> [b]
map Type -> ClassName2VarNames
toClassInfo

toClassInfo :: Pred -> ClassName2VarNames
toClassInfo :: Type -> ClassName2VarNames
toClassInfo (AppT Type
t1 Type
t2) = do
  let (ClassName2VarNames Name
name [Name]
vars) = Type -> ClassName2VarNames
toClassInfo Type
t1
  Name -> [Name] -> ClassName2VarNames
ClassName2VarNames Name
name ([Name]
vars [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Type -> [Name]
getTypeNames Type
t2)
toClassInfo (ConT Name
name) = Name -> [Name] -> ClassName2VarNames
ClassName2VarNames Name
name []
toClassInfo Type
_ = String -> ClassName2VarNames
forall a. HasCallStack => String -> a
error String
"Unsupported Type structure"

getTypeNames :: Pred -> [Name]
getTypeNames :: Type -> [Name]
getTypeNames (VarT Name
name) = [Name
name]
getTypeNames (ConT Name
name) = [Name
name]
getTypeNames Type
_ = []

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 ()]
typeVars [FunDep]
_ [Dec]
_) [Dec]
_ <- Name -> Q Info
reify Name
cName
      let
        -- type variable names
        typeVarNames :: [Name]
typeVarNames = [TyVarBndr ()] -> [Name]
forall a. [TyVarBndr a] -> [Name]
getTypeVarNames [TyVarBndr ()]
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

filterClassInfo :: Name -> [ClassName2VarNames] -> [ClassName2VarNames]
filterClassInfo :: Name -> [ClassName2VarNames] -> [ClassName2VarNames]
filterClassInfo Name
name = (ClassName2VarNames -> Bool)
-> [ClassName2VarNames] -> [ClassName2VarNames]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> ClassName2VarNames -> Bool
hasVarName Name
name)
  where
  hasVarName :: Name -> ClassName2VarNames -> Bool
  hasVarName :: Name -> ClassName2VarNames -> Bool
hasVarName Name
name (ClassName2VarNames Name
_ [Name]
varNames) = Name
name Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
varNames

filterMonadicVarInfos :: [VarName2ClassNames] -> [VarName2ClassNames]
filterMonadicVarInfos :: [VarName2ClassNames] -> [VarName2ClassNames]
filterMonadicVarInfos = (VarName2ClassNames -> Bool)
-> [VarName2ClassNames] -> [VarName2ClassNames]
forall a. (a -> Bool) -> [a] -> [a]
filter VarName2ClassNames -> Bool
hasMonadInVarInfo

hasMonadInVarInfo :: VarName2ClassNames -> Bool
hasMonadInVarInfo :: VarName2ClassNames -> Bool
hasMonadInVarInfo (VarName2ClassNames Name
_ [Name]
classNames) = ''Monad Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
classNames

createCxt :: Name -> Cxt -> Q Cxt
createCxt :: Name -> Cxt -> Q Cxt
createCxt Name
monadVarName = (Type -> Q Type) -> Cxt -> Q Cxt
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 -> Type -> Q Type
createPred Name
monadVarName)

createPred :: Name -> Pred -> Q Pred
createPred :: Name -> Type -> Q Type
createPred Name
monadVarName a :: Type
a@(AppT t :: Type
t@(ConT Name
ty) b :: Type
b@(VarT Name
varName))
  | Name
monadVarName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
varName Bool -> Bool -> Bool
&& Name
ty Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Monad = Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a
  | Name
monadVarName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
varName Bool -> Bool -> Bool
&& Name
ty Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= ''Monad = Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t) (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''MockT) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
varName))
  | Bool
otherwise = Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Type -> Q Type
createPred Name
monadVarName Type
t) (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
b)
createPred Name
monadVarName (AppT Type
ty a :: Type
a@(VarT Name
varName))
  | Name
monadVarName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
varName = Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty) (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''MockT) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
varName))
  | Bool
otherwise = Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Type -> Q Type
createPred Name
monadVarName Type
ty) (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a)
createPred Name
monadVarName (AppT Type
ty1 Type
ty2) = Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Type -> Q Type
createPred Name
monadVarName Type
ty1) (Name -> Type -> Q Type
createPred Name
monadVarName Type
ty2)
createPred Name
_ Type
ty = Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty

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
  Cxt
types <- (TyVarBndr a -> Q Type) -> [TyVarBndr a] -> Q Cxt
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 -> Q Type
forall a. Name -> TyVarBndr a -> Q 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

tyVarBndrToType :: Name -> TyVarBndr a -> Q Type
tyVarBndrToType :: forall a. Name -> TyVarBndr a -> Q Type
tyVarBndrToType Name
monadName (PlainTV Name
name a
_)
  | Name
monadName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name = Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''MockT) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
monadName)
  | Bool
otherwise = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
name
tyVarBndrToType Name
monadName (KindedTV Name
name a
_ Type
_)
  | Name
monadName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name = Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''MockT) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
monadName)
  | Bool
otherwise = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
name

createInstanceFnDec :: MockOptions -> Dec -> Q Dec
createInstanceFnDec :: MockOptions -> Dec -> Q Dec
createInstanceFnDec 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
      genStubFn :: Q Exp -> Q Exp
genStubFn = case [Name]
names of
        [] -> $([|generateConstantStubFn|])
        [Name]
_  -> $([|generateStubFn args|])

      fnBody :: Q Exp
fnBody = [| MockT $ do
                    defs <- get
                    let mock = defs
                               & findParam (Proxy :: Proxy $(Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (String -> Q TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit String
fnNameStr)))
                               & fromMaybe (error $ "no answer found stub function `" ++ fnNameStr ++ "`.")
                        $(Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Pat
bangP (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
r) = $(Q Exp -> Q Exp
genStubFn [| mock |])
                    pure $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
r) |]
      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 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

generateStubFn :: [Q Exp] -> Q Exp -> Q Exp
generateStubFn :: [Q Exp] -> Q Exp -> Q Exp
generateStubFn [Q Exp]
args Q Exp
mock = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| stubFn $(Q Exp
mock) |] [Q Exp]
args

generateConstantStubFn :: Q Exp -> Q Exp
generateConstantStubFn :: Q Exp -> Q Exp
generateConstantStubFn Q Exp
mock = [| stubFn $(Q Exp
mock) |]

createMockFnDec :: Name -> [VarAppliedType] -> MockOptions -> Dec -> Q [Dec]
createMockFnDec :: Name -> [VarAppliedType] -> MockOptions -> Dec -> Q [Dec]
createMockFnDec Name
monadVarName [VarAppliedType]
varAppliedTypes MockOptions
options (SigD Name
funName Type
ty) = do
  let funNameStr :: String
funNameStr = Name -> MockOptions -> String
createFnName Name
funName MockOptions
options
      mockFunName :: Name
mockFunName = String -> Name
mkName String
funNameStr
      params :: Name
params = String -> Name
mkName String
"p"

  if Type -> Bool
isConstant Type
ty then
    String -> Name -> Name -> Name -> Q [Dec]
forall (m :: * -> *).
Quote m =>
String -> Name -> Name -> Name -> m [Dec]
doCreateConstantMockFnDec String
funNameStr Name
mockFunName Name
params Name
monadVarName
  else do
    let
      updatedType :: Type
updatedType = Type -> [VarAppliedType] -> Type
updateType Type
ty [VarAppliedType]
varAppliedTypes
      funType :: Type
funType = Name -> Type -> Type
createMockBuilderFnType Name
monadVarName Type
updatedType
    String -> Name -> Name -> Type -> Name -> Type -> Q [Dec]
forall (m :: * -> *).
Quote m =>
String -> Name -> Name -> Type -> Name -> Type -> m [Dec]
doCreateMockFnDec String
funNameStr Name
mockFunName Name
params Type
funType Name
monadVarName Type
updatedType

createMockFnDec 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

doCreateMockFnDec :: Quote m => String -> Name -> Name -> Type -> Name -> Type -> m [Dec]
doCreateMockFnDec :: forall (m :: * -> *).
Quote m =>
String -> Name -> Name -> Type -> Name -> Type -> m [Dec]
doCreateMockFnDec String
funNameStr Name
mockFunName Name
params Type
funType Name
monadVarName Type
updatedType = do
  Dec
newFunSig <- do
    let verifyParams :: Type
verifyParams = Type -> Type
createMockBuilderVerifyParams Type
updatedType
    Name -> m Type -> m Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
mockFunName [t|
      (MockBuilder $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
params) ($(Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
funType)) ($(Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
verifyParams)), Monad $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
monadVarName))
      => $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
params) -> MockT $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
monadVarName) ()|]

  Exp
createMockFn <- [|createNamedMock|]

  Exp
mockBody <- String -> Exp -> m Exp
forall (m :: * -> *). Quote m => String -> Exp -> m Exp
createMockBody String
funNameStr Exp
createMockFn
  Dec
newFun <- Name -> [m Clause] -> m Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
mockFunName [[m Pat] -> m Body -> [m Dec] -> m Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> m Pat) -> Name -> m Pat
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"p"] (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
mockBody)) []]

  [Dec] -> m [Dec]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> m [Dec]) -> [Dec] -> m [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
newFunSig Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec
newFun]

doCreateConstantMockFnDec :: Quote m => String -> Name -> Name -> Name -> m [Dec]
doCreateConstantMockFnDec :: forall (m :: * -> *).
Quote m =>
String -> Name -> Name -> Name -> m [Dec]
doCreateConstantMockFnDec String
funNameStr Name
mockFunName Name
params Name
monadVarName = do
  Dec
newFunSig <- Name -> m Type -> m Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
mockFunName [t|Monad $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
monadVarName) => $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
params) -> MockT $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
monadVarName) ()|]
  Exp
createMockFn <- [|createNamedConstantMock|]
  Exp
mockBody <- String -> Exp -> m Exp
forall (m :: * -> *). Quote m => String -> Exp -> m Exp
createMockBody String
funNameStr Exp
createMockFn
  Dec
newFun <- Name -> [m Clause] -> m Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
mockFunName [[m Pat] -> m Body -> [m Dec] -> m Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> m Pat) -> Name -> m Pat
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"p"] (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
mockBody)) []]
  [Dec] -> m [Dec]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> m [Dec]) -> [Dec] -> m [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
newFunSig Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec
newFun]

createMockBody :: Quote m => String -> Exp -> m Exp
createMockBody :: forall (m :: * -> *). Quote m => String -> Exp -> m Exp
createMockBody String
funNameStr Exp
createMockFn =
  [| MockT $ modify (++ [Definition
                    (Proxy :: Proxy $(m TyLit -> m Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (String -> m TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit String
funNameStr)))
                    (unsafePerformIO $ $(Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
createMockFn) $(Lit -> m Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL String
funNameStr)) p)
                    shouldApplyToAnything]) |]

isConstant :: Type -> Bool
isConstant :: Type -> Bool
isConstant (AppT (VarT Name
_) (VarT Name
_)) = Bool
True
isConstant (VarT Name
_) = Bool
True
isConstant (ConT Name
_) = Bool
True
isConstant Type
_ = Bool
False

updateType :: Type -> [VarAppliedType] -> Type
updateType :: Type -> [VarAppliedType] -> Type
updateType (AppT (VarT Name
v1) (VarT Name
v2)) [VarAppliedType]
varAppliedTypes = do
  let
    x :: Type
x = Type -> (Name -> Type) -> Maybe Name -> Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> Type
VarT Name
v1) Name -> Type
ConT (Name -> [VarAppliedType] -> Maybe Name
findClass Name
v1 [VarAppliedType]
varAppliedTypes)
    y :: Type
y = Type -> (Name -> Type) -> Maybe Name -> Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> Type
VarT Name
v2) Name -> Type
ConT (Name -> [VarAppliedType] -> Maybe Name
findClass Name
v2 [VarAppliedType]
varAppliedTypes)
  Type -> Type -> Type
AppT Type
x Type
y
updateType Type
ty [VarAppliedType]
_ = Type
ty

hasClass :: Name -> [VarAppliedType] -> Bool
hasClass :: Name -> [VarAppliedType] -> Bool
hasClass Name
varName = (VarAppliedType -> Bool) -> [VarAppliedType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(VarAppliedType Name
v Maybe Name
c) -> (Name
v Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
varName) Bool -> Bool -> Bool
&& Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust Maybe Name
c)

findClass :: Name -> [VarAppliedType] -> Maybe Name
findClass :: Name -> [VarAppliedType] -> Maybe Name
findClass Name
varName [VarAppliedType]
types = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Name -> [VarAppliedType] -> Bool
hasClass Name
varName [VarAppliedType]
types
  (VarAppliedType Name
_ Maybe Name
c) <- (VarAppliedType -> Bool)
-> [VarAppliedType] -> Maybe VarAppliedType
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(VarAppliedType Name
v Maybe Name
_) -> Name
v Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
varName) [VarAppliedType]
types
  Maybe Name
c

createFnName :: Name -> MockOptions -> String
createFnName :: Name -> MockOptions -> String
createFnName Name
funName MockOptions
options = do
  MockOptions
options.prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase Name
funName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> MockOptions
options.suffix

createMockBuilderFnType :: Name -> Type -> Type
createMockBuilderFnType :: Name -> Type -> Type
createMockBuilderFnType Name
monadVarName a :: Type
a@(AppT (VarT Name
var) Type
ty)
  | Name
monadVarName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
var = Type
ty
  | Bool
otherwise = Type
a
createMockBuilderFnType Name
monadVarName (AppT Type
ty Type
ty2) = Type -> Type -> Type
AppT Type
ty (Name -> Type -> Type
createMockBuilderFnType Name
monadVarName Type
ty2)
createMockBuilderFnType Name
monadVarName (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
ty) = Name -> Type -> Type
createMockBuilderFnType Name
monadVarName Type
ty
createMockBuilderFnType Name
_ Type
ty = Type
ty

createMockBuilderVerifyParams :: Type -> Type
createMockBuilderVerifyParams :: Type -> Type
createMockBuilderVerifyParams (AppT (AppT Type
ArrowT Type
ty) (AppT (VarT Name
_) Type
_)) = Type -> Type -> Type
AppT (Name -> Type
ConT ''Param) Type
ty
createMockBuilderVerifyParams (AppT (AppT Type
ArrowT Type
ty) Type
ty2) =
  Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''(:>)) (Type -> Type -> Type
AppT (Name -> Type
ConT ''Param) Type
ty) ) (Type -> Type
createMockBuilderVerifyParams Type
ty2)
createMockBuilderVerifyParams (AppT (VarT Name
_) (ConT Name
c)) = Type -> Type -> Type
AppT (Name -> Type
ConT ''Param) (Name -> Type
ConT Name
c)
createMockBuilderVerifyParams (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
ty) = Type -> Type
createMockBuilderVerifyParams Type
ty
createMockBuilderVerifyParams Type
a = Type
a

findParam :: KnownSymbol sym => Proxy sym -> [Definition] -> Maybe a
findParam :: forall (sym :: Symbol) a.
KnownSymbol sym =>
Proxy sym -> [Definition] -> Maybe a
findParam Proxy sym
pa [Definition]
definitions = do
  let definition :: Maybe Definition
definition = (Definition -> Bool) -> [Definition] -> Maybe Definition
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Definition Proxy sym
s Mock f p
_ Mock f p -> IO ()
_) -> Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy sym
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy sym
pa) [Definition]
definitions
  (Definition -> a) -> Maybe Definition -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Definition Proxy sym
_ Mock f p
mock Mock f p -> IO ()
_) -> Mock f p -> a
forall a b. a -> b
unsafeCoerce Mock f p
mock) Maybe Definition
definition

typeToNames :: Type -> [Q Name]
typeToNames :: Type -> [Q Name]
typeToNames (AppT (AppT Type
ArrowT Type
_) Type
t2) = String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a" Q Name -> [Q Name] -> [Q Name]
forall a. a -> [a] -> [a]
: Type -> [Q Name]
typeToNames Type
t2
typeToNames (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
ty) = Type -> [Q Name]
typeToNames Type
ty
typeToNames Type
_ = []

getClassName :: Type -> Name
getClassName :: Type -> Name
getClassName (ConT Name
name) = Name
name
getClassName (AppT Type
ty Type
_) = Type -> Name
getClassName Type
ty
getClassName Type
d = String -> Name
forall a. HasCallStack => String -> a
error (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"unsupported class definition: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
d

getClassNames :: Type -> [Name]
getClassNames :: Type -> [Name]
getClassNames (AppT (ConT Name
name1) (ConT Name
name2)) = [Name
name1, Name
name2]
getClassNames (AppT Type
ty (ConT Name
name)) = Type -> [Name]
getClassNames Type
ty [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
name]
getClassNames (AppT Type
ty1 Type
ty2) = Type -> [Name]
getClassNames Type
ty1 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Type -> [Name]
getClassNames Type
ty2
getClassNames Type
_ = []

data ClassName2VarNames = ClassName2VarNames Name [Name]

instance Show ClassName2VarNames where
  show :: ClassName2VarNames -> String
show (ClassName2VarNames Name
cName [Name]
varNames) = Name -> [Name] -> String
showClassDef Name
cName [Name]
varNames

data VarName2ClassNames = VarName2ClassNames Name [Name]

instance Show VarName2ClassNames where
  show :: VarName2ClassNames -> String
show (VarName2ClassNames Name
varName [Name]
classNames) = Name -> String
forall a. Show a => a -> String
show Name
varName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" class is " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords (Name -> String
showClassName (Name -> String) -> [Name] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
classNames)

data VarAppliedType = VarAppliedType { VarAppliedType -> Name
name :: Name, VarAppliedType -> Maybe Name
appliedClassName :: Maybe Name }
  deriving (Int -> VarAppliedType -> String -> String
[VarAppliedType] -> String -> String
VarAppliedType -> String
(Int -> VarAppliedType -> String -> String)
-> (VarAppliedType -> String)
-> ([VarAppliedType] -> String -> String)
-> Show VarAppliedType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> VarAppliedType -> String -> String
showsPrec :: Int -> VarAppliedType -> String -> String
$cshow :: VarAppliedType -> String
show :: VarAppliedType -> String
$cshowList :: [VarAppliedType] -> String -> String
showList :: [VarAppliedType] -> String -> String
Show)

showClassName :: Name -> String
showClassName :: Name -> String
showClassName Name
n = String -> String -> String
splitLast String
"." (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Show a => a -> String
show Name
n

showClassDef :: Name -> [Name] -> String
showClassDef :: Name -> [Name] -> String
showClassDef Name
className [Name]
varNames = Name -> String
showClassName Name
className String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords (Name -> String
forall a. Show a => a -> String
show (Name -> String) -> [Name] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
varNames)

splitLast :: String -> String -> String
splitLast :: String -> String -> String
splitLast String
delimiter = [String] -> String
forall a. HasCallStack => [a] -> a
last ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
split String
delimiter

split :: String -> String -> [String]
split :: String -> String -> [String]
split String
delimiter String
str = Text -> String
unpack (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
splitOn (String -> Text
pack String
delimiter) (String -> Text
pack String
str)

safeIndex :: [a] -> Int -> Maybe a
safeIndex :: forall a. [a] -> Int -> Maybe a
safeIndex [] Int
_ = Maybe a
forall a. Maybe a
Nothing
safeIndex (a
x:[a]
_) Int
0 = a -> Maybe a
forall a. a -> Maybe a
Just a
x
safeIndex (a
_:[a]
xs) Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0     = Maybe a
forall a. Maybe a
Nothing
  | Bool
otherwise = [a] -> Int -> Maybe a
forall a. [a] -> Int -> Maybe a
safeIndex [a]
xs (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

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.")