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

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

import Control.Monad (guard, unless)
import Control.Monad.State (get, modify)
import Control.Monad.Trans.Class (lift)
import Data.Data (Proxy (..))
import Data.Function ((&))
import Data.List (elemIndex, find, nub)
import Data.Maybe (fromMaybe, isJust)
import Data.Text (pack, splitOn, unpack)
import GHC.IO (unsafePerformIO)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Language.Haskell.TH
  ( Cxt,
    Dec (..),
    Exp (..),
    Extension (..),
    Info (..),
    Lit (..),
    Name,
    Pat (..),
    Pred,
    Q,
    Quote (newName),
    TyVarBndr (..),
    Type (..),
    isExtEnabled,
    mkName,
    pprint,
    reify,
    Inline (NoInline),
    RuleMatch (FunLike),
    Phases (AllPhases),
  )
import Language.Haskell.TH.Lib
import Language.Haskell.TH.PprLib (Doc, hcat, parens, text)
import Language.Haskell.TH.Syntax (nameBase)
import Test.MockCat.Cons
import Test.MockCat.Mock
import Test.MockCat.MockT
import Test.MockCat.Param
import Unsafe.Coerce (unsafeCoerce)
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 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|]

data MockType = Total | Partial deriving (MockType -> MockType -> Bool
(MockType -> MockType -> Bool)
-> (MockType -> MockType -> Bool) -> Eq MockType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MockType -> MockType -> Bool
== :: MockType -> MockType -> Bool
$c/= :: MockType -> MockType -> Bool
/= :: MockType -> MockType -> Bool
Eq)

-- | Options for generating mocks.
--
--  - prefix: Stub function prefix
--  - suffix: stub function suffix
--  - implicitMonadicReturn: If True, the return value of the stub function is wrapped in a monad automatically.
--                           If Else, the return value of stub function is not wrapped in a monad,  so required explicitly return monadic values.
data MockOptions = MockOptions {MockOptions -> String
prefix :: String, MockOptions -> String
suffix :: String, MockOptions -> Bool
implicitMonadicReturn :: Bool}

-- | Default Options.
--
--  Stub function names are prefixed with “_”.
options :: MockOptions
options :: MockOptions
options = MockOptions {prefix :: String
prefix = String
"_", suffix :: String
suffix = String
"", implicitMonadicReturn :: Bool
implicitMonadicReturn = Bool
True}

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

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

doMakeMock :: Q Type -> MockType -> MockOptions -> Q [Dec]
doMakeMock :: Q Type -> MockType -> MockOptions -> Q [Dec]
doMakeMock Q Type
t MockType
mockType 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
-> 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 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 -> 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 ..]

  Dec
instanceDec <-
    Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
      (Cxt
-> MockType
-> Name
-> Name
-> [TyVarBndr a]
-> [VarAppliedType]
-> Q Cxt
forall a.
Cxt
-> MockType
-> Name
-> Name
-> [TyVarBndr a]
-> [VarAppliedType]
-> Q Cxt
createCxt Cxt
cxt MockType
mockType Name
className Name
monadVarName [TyVarBndr a]
newTypeVars [VarAppliedType]
varAppliedTypes)
      (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 (MockType -> MockOptions -> Dec -> Q Dec
createInstanceFnDec MockType
mockType 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 :: [Pred] -> MockType -> Name -> Name -> [TyVarBndr a] -> [VarAppliedType] -> Q [Pred]
createCxt :: forall a.
Cxt
-> MockType
-> Name
-> Name
-> [TyVarBndr a]
-> [VarAppliedType]
-> Q Cxt
createCxt Cxt
cxt MockType
mockType Name
className Name
monadVarName [TyVarBndr a]
tyVars [VarAppliedType]
varAppliedTypes = do
  Cxt
newCxt <- (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) Cxt
cxt

  Type
monadAppT <- 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
P.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

  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
$ case MockType
mockType of
    MockType
Total -> Cxt
newCxt Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ ([Type
monadAppT | Bool -> Bool
not Bool
hasMonad])
    MockType
Partial -> do
      let classAppT :: Type
classAppT = Name -> Cxt -> Type
constructClassAppT Name
className (Cxt -> Type) -> Cxt -> Type
forall a b. (a -> b) -> a -> b
$ [TyVarBndr a] -> Cxt
forall a. [TyVarBndr a] -> Cxt
toVarTs [TyVarBndr a]
tyVars
          varAppliedClassAppT :: Type
varAppliedClassAppT = Type -> [VarAppliedType] -> Type
updateType Type
classAppT [VarAppliedType]
varAppliedTypes
      Cxt
newCxt Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ ([Type
monadAppT | Bool -> Bool
not Bool
hasMonad]) Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ [Type
varAppliedClassAppT]

toVarTs :: [TyVarBndr a] -> [Type]
toVarTs :: forall a. [TyVarBndr a] -> Cxt
toVarTs [TyVarBndr a]
tyVars = Name -> Type
VarT (Name -> Type) -> [Name] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr a] -> [Name]
forall a. [TyVarBndr a] -> [Name]
getTypeVarNames [TyVarBndr a]
tyVars

constructClassAppT :: Name -> [Type] -> Type
constructClassAppT :: Name -> Cxt -> Type
constructClassAppT Name
className = (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
className)

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 :: 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

generateInstanceMockFnBody :: String -> [Q Exp] -> Name -> MockOptions -> Q Exp
generateInstanceMockFnBody :: String -> [Q Exp] -> Name -> MockOptions -> Q Exp
generateInstanceMockFnBody String
fnNameStr [Q Exp]
args Name
r MockOptions
options = do
  Exp
returnExp <- if MockOptions
options.implicitMonadicReturn
    then [| pure $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
r) |]
    else [| lift $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
r) |]
  [|
    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 -> Q Exp
generateStubFn [Q Exp]
args [|mock|])
      $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
returnExp)
    |]

generateInstanceRealFnBody :: Name -> String -> [Q Exp] -> Name -> MockOptions -> Q Exp
generateInstanceRealFnBody :: Name -> String -> [Q Exp] -> Name -> MockOptions -> Q Exp
generateInstanceRealFnBody Name
fnName String
fnNameStr [Q Exp]
args Name
r MockOptions
options = do
  Exp
returnExp <- if MockOptions
options.implicitMonadicReturn
    then [| pure $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
r) |]
    else [| lift $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
r) |]
  [|
    MockT $ do
      defs <- get
      case 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))) defs of
        Just mock -> do
          let $(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 -> Q Exp
generateStubFn [Q Exp]
args [|mock|])
          $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
returnExp)
        Nothing -> lift $ $((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 (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fnName) [Q Exp]
args)
    |]

generateStubFn :: [Q Exp] -> Q Exp -> Q Exp
generateStubFn :: [Q Exp] -> Q Exp -> Q Exp
generateStubFn [] = $([|generateConstantStubFn|])
generateStubFn [Q Exp]
args = $([|generateNotConstantsStubFn args|])

generateNotConstantsStubFn :: [Q Exp] -> Q Exp -> Q Exp
generateNotConstantsStubFn :: [Q Exp] -> Q Exp -> Q Exp
generateNotConstantsStubFn [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
sigFnName Type
ty) = do
  let fnName :: String
fnName = Name -> MockOptions -> String
createFnName Name
sigFnName MockOptions
options
      mockFnName :: Name
mockFnName = String -> Name
mkName String
fnName
      params :: Name
params = String -> Name
mkName String
"p"
      updatedType :: Type
updatedType = Type -> [VarAppliedType] -> Type
updateType Type
ty [VarAppliedType]
varAppliedTypes
      fnType :: Type
fnType = if MockOptions
options.implicitMonadicReturn
        then Name -> Type -> Type
createMockBuilderFnType Name
monadVarName Type
updatedType
        else Type
updatedType

  [Dec]
fnDecs <- if Type -> Bool
isNotConstantFunctionType Type
ty then
    String -> Name -> Name -> Type -> Name -> Type -> Q [Dec]
forall (m :: * -> *).
Quote m =>
String -> Name -> Name -> Type -> Name -> Type -> m [Dec]
doCreateMockFnDecs String
fnName Name
mockFnName Name
params Type
fnType Name
monadVarName Type
updatedType
  else
    if MockOptions
options.implicitMonadicReturn then
      String -> Name -> Type -> Name -> Q [Dec]
forall (m :: * -> *).
Quote m =>
String -> Name -> Type -> Name -> m [Dec]
doCreateConstantMockFnDecs String
fnName Name
mockFnName Type
fnType Name
monadVarName
    else
      String -> Name -> Name -> Type -> Name -> Type -> Q [Dec]
forall (m :: * -> *).
Quote m =>
String -> Name -> Name -> Type -> Name -> Type -> m [Dec]
doCreateEmptyVerifyParamMockFnDecs String
fnName Name
mockFnName Name
params Type
fnType Name
monadVarName Type
updatedType

  Dec
pragmaDec <- Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
mockFnName Inline
NoInline RuleMatch
FunLike Phases
AllPhases

  [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

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

doCreateMockFnDecs :: (Quote m) => String -> Name -> Name -> Type -> Name -> Type -> m [Dec]
doCreateMockFnDecs :: forall (m :: * -> *).
Quote m =>
String -> Name -> Name -> Type -> Name -> Type -> m [Dec]
doCreateMockFnDecs 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]

doCreateConstantMockFnDecs :: (Quote m) => String -> Name -> Type -> Name -> m [Dec]
doCreateConstantMockFnDecs :: forall (m :: * -> *).
Quote m =>
String -> Name -> Type -> Name -> m [Dec]
doCreateConstantMockFnDecs String
funNameStr Name
mockFunName Type
ty 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)) => $(Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty) -> 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]

-- MockBuilder constraints, but verifyParams are empty.
doCreateEmptyVerifyParamMockFnDecs :: (Quote m) => String -> Name -> Name -> Type -> Name -> Type -> m [Dec]
doCreateEmptyVerifyParamMockFnDecs :: forall (m :: * -> *).
Quote m =>
String -> Name -> Name -> Type -> Name -> Type -> m [Dec]
doCreateEmptyVerifyParamMockFnDecs 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)) (), 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]

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

isNotConstantFunctionType :: Type -> Bool
isNotConstantFunctionType :: Type -> Bool
isNotConstantFunctionType (AppT (AppT Type
ArrowT Type
_) Type
_) = Bool
True
isNotConstantFunctionType (AppT Type
t1 Type
t2) = Type -> Bool
isNotConstantFunctionType Type
t1 Bool -> Bool -> Bool
|| Type -> Bool
isNotConstantFunctionType Type
t2
isNotConstantFunctionType (TupleT Int
_) = Bool
False
isNotConstantFunctionType (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
t) = Type -> Bool
isNotConstantFunctionType Type
t
isNotConstantFunctionType 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
P.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.")