{-# 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,
  )
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
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
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"
      updatedType :: Type
updatedType = Type -> [VarAppliedType] -> Type
updateType Type
ty [VarAppliedType]
varAppliedTypes
      funType :: Type
funType = if MockOptions
options.implicitMonadicReturn 
        then Name -> Type -> Type
createMockBuilderFnType Name
monadVarName Type
updatedType
        else Type
updatedType

  if Type -> Bool
isFunctionType Type
ty then
    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
  else
    if MockOptions
options.implicitMonadicReturn then
      String -> Name -> Type -> Name -> Q [Dec]
forall (m :: * -> *).
Quote m =>
String -> Name -> Type -> Name -> m [Dec]
doCreateConstantMockFnDec String
funNameStr Name
mockFunName Type
funType Name
monadVarName
    else
      String -> Name -> Name -> Type -> Name -> Type -> Q [Dec]
forall (m :: * -> *).
Quote m =>
String -> Name -> Name -> Type -> Name -> Type -> m [Dec]
doCreateMockFnDec2 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 -> Type -> Name -> m [Dec]
doCreateConstantMockFnDec :: forall (m :: * -> *).
Quote m =>
String -> Name -> Type -> Name -> m [Dec]
doCreateConstantMockFnDec 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]

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

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