method 0.3.1.0 → 0.4.0.0
raw patch · 9 files changed
+499/−87 lines, 9 filesdep +containersdep +template-haskelldep +th-abstraction
Dependencies added: containers, template-haskell, th-abstraction
Files
- CHANGELOG.md +3/−0
- method.cabal +9/−4
- src/Control/Method/Internal.hs +17/−2
- src/Test/Method.hs +35/−21
- src/Test/Method/Dynamic.hs +5/−0
- src/Test/Method/Label.hs +275/−0
- src/Test/Method/Protocol.hs +29/−27
- test/Test/Method/LabelSpec.hs +79/−0
- test/Test/Method/ProtocolSpec.hs +47/−33
CHANGELOG.md view
@@ -1,5 +1,8 @@ # Revision history for method +## 0.4.0.0 -- 2021-05-XX+* Add type class `Label` and template-haskell function `deriveLabel`. + ## 0.3.1.0 -- 2021-04-16 * Add `Interface` type class and function `mapBaseRIO`. [\#11](https://github.com/autotaker/method/issues/11)
method.cabal view
@@ -4,7 +4,7 @@ -- For further documentation, see http://haskell.org/cabal/users-guide/ name: method-version: 0.3.1.0+version: 0.4.0.0 synopsis: rebindable methods for improving testability description: This package provides Method typeclass, which represents @@ -25,9 +25,12 @@ common shared-properties build-depends:- , base >=4.13.0.0 && <5.0- , rio ^>=0.1.19.0- , transformers ^>=0.5.6.2+ , base >=4.13.0.0 && <5.0+ , containers+ , rio ^>=0.1.19.0+ , template-haskell >=2.15 && <2.17+ , th-abstraction ^>=0.4.2+ , transformers ^>=0.5.6.2 default-language: Haskell2010 ghc-options:@@ -48,6 +51,7 @@ Test.Method Test.Method.Behavior Test.Method.Dynamic+ Test.Method.Label Test.Method.Matcher Test.Method.Mock Test.Method.Monitor@@ -68,6 +72,7 @@ -- cabal-fmt: expand test -Spec other-modules: Test.Method.DynamicSpec+ Test.Method.LabelSpec Test.Method.MockSpec Test.Method.MonitorSpec Test.Method.ProtocolSpec
src/Control/Method/Internal.hs view
@@ -80,10 +80,25 @@ -- | Nullary tuple data Nil = Nil- deriving (Eq, Ord, Show)+ deriving (Eq, Ord) -- | Tuple constructor data a :* b = a :* !b- deriving (Eq, Ord, Show, Generic)+ deriving (Eq, Ord, Generic)++instance Show Nil where+ showsPrec _ Nil = showString "()"++instance (Show a, ShowTuple b) => Show (a :* b) where+ showsPrec _ (a :* b) = showsTuple (shows a) b++class ShowTuple a where+ showsTuple :: ShowS -> a -> ShowS++instance ShowTuple Nil where+ showsTuple acc Nil = showParen True acc++instance (Show a, ShowTuple b) => ShowTuple (a :* b) where+ showsTuple acc (a :* b) = showsTuple (acc . showString ", " . shows a) b infixr 1 :*
src/Test/Method.hs view
@@ -61,12 +61,16 @@ -- ** References protocol,+ withProtocol, ProtocolM, ProtocolEnv, CallId,+ deriveLabel,+ (:|:) (L, R), decl, whenArgs, dependsOn,+ mockInterface, lookupMock, lookupMockWithShow, verify,@@ -88,6 +92,15 @@ where import Test.Method.Dynamic+ ( Dynamic,+ DynamicShow,+ FromDyn (fromDyn),+ ToDyn (toDyn),+ Typeable,+ castMethod,+ dynArg,+ )+import Test.Method.Label (deriveLabel, (:|:) (L, R)) import Test.Method.Matcher ( ArgsMatcher (..), Matcher,@@ -124,9 +137,11 @@ dependsOn, lookupMock, lookupMockWithShow,+ mockInterface, protocol, verify, whenArgs,+ withProtocol, ) -- $usage@@ -242,19 +257,24 @@ -- 1. If @findUser@ returns @Just user@, it returns @Nothing@ without calling @createUser@. -- 2. If @findUser@ returns @Nothing@, it calls @createUser@ and returns the created user. ----- In order to write Protocol DSL, first you define a GADT functor that--- represents labels of dependent methods.+-- In order to write Protocol DSL, first call template haskell 'deriveLabel',+-- which define a GADT functor that represents labels of dependent methods. -- -- @--- data Methods m where--- FindUser :: Methods (UserName -> IO (Maybe UserId))--- CreateUser :: Methods (UserName -> IO UserId)+-- deriveLabel ''Service+-- @ ----- deriving instance (Show (Methods m))--- deriving instance (Eq (Methods m))--- deriving instance (Ord (Methods m))+-- This generates the following boilerplate.+-- -- @+-- data ServiceLabel m where+-- FindUser :: ServiceLabel (UserName -> IO (Maybe UserId))+-- CreateUser :: ServiceLabel (UserName -> IO UserId) --+-- instance 'Label' ServiceLabel where+-- ...+-- @+-- -- Then, you can write test for the specification. -- -- @@@ -270,24 +290,18 @@ -- 'decl' $ 'whenArgs' FindUser (==username) ``thenReturn`` Just userId -- -- mocking methods from protocol env. Each mock method raises an exception -- -- if it is called in a different way than that specified by the protocol.--- let service = Service {--- findUser = 'lookupMock' FindUser env,--- createUser = 'lookupMock' CreateUser env--- }+-- let service = mockInterface env -- signup service username \`shouldReturn\` Nothing -- -- Checks all calls specified by the protocol are called. -- 'verify' env -- -- it "call ``createUser`` and return `Just userId`" $ do--- env <- protocol $ do--- findUserCall <- 'decl' $ 'whenArgs' FindUser (==username) ``thenReturn`` Nothing--- 'decl' $ 'whenArgs' CreateUser (==username) ``thenReturn`` Just userId ``dependsOn`` [findUserCall]--- let service = Service {--- findUser = 'lookupMock' FindUser env,--- createUser = 'lookupMock' CreateUser env--- }--- signup service username ``shouldReturn`` Just userId--- 'verify' env+-- let proto = do+-- findUserCall <- 'decl' $ 'whenArgs' FindUser (==username) ``thenReturn`` Nothing+-- 'decl' $ 'whenArgs' CreateUser (==username) ``thenReturn`` Just userId ``dependsOn`` [findUserCall]+-- -- 'withProtocol' is easier API+-- 'withProtocol' proto $ \\service ->+-- signup service username \`shouldReturn\` Just userId -- @ -- -- Protocol DSL consists of method call declarations like:
src/Test/Method/Dynamic.hs view
@@ -200,6 +200,11 @@ method' castMethod method = curryMethod $ \args -> fromDyn <$> uncurryMethod method (toDyn args)+{-# INLINE [1] castMethod #-}++{-# RULES+"castMethod/id" castMethod = id+ #-} fromDynamic :: forall a d. (Typeable a, DynamicLike d, Show d) => d -> a fromDynamic v =
+ src/Test/Method/Label.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module : Test.Method.Label+-- Description:+-- License: BSD-3+-- Maintainer: autotaker@gmail.com+-- Stability: experimental+module Test.Method.Label (Label (..), (:|:) (..), deriveLabel) where++import Control.Method (Method (Args, Base))+import Control.Monad.IO.Class (MonadIO)+import Data.Char (isLower, toUpper)+import qualified Data.Kind as K+import qualified Data.List as L+import qualified Data.Map.Strict as M+import Data.Typeable (Typeable)+import Language.Haskell.TH+ ( Dec,+ DecQ,+ DecsQ,+ Name,+ Pred,+ Q,+ TyVarBndr (KindedTV, PlainTV),+ Type (AppT, ArrowT, ConT, ForallT, InfixT, ListT, SigT, TupleT, VarT),+ appE,+ appT,+ caseE,+ conE,+ conP,+ conT,+ cxt,+ dataD,+ gadtC,+ instanceD,+ lam1E,+ match,+ mkName,+ nameBase,+ newName,+ normalB,+ pprint,+ stringE,+ tySynEqn,+ tySynInstD,+ valD,+ varE,+ varP,+ varT,+ )+import qualified Language.Haskell.TH.Datatype as D+import Test.Method.Dynamic (Dynamic, DynamicShow, castMethod)++-- | Type class that represents @f@ denotes the type of field names of @InterfaceOf f@+class Typeable f => Label (f :: K.Type -> K.Type) where+ -- | Interface type corrensponding to @f@+ type InterfaceOf f++ -- | Construct a interface from polymorphic function that returns each field of the interface.+ toInterface ::+ ( forall m.+ ( Typeable m,+ Method m,+ MonadIO (Base m),+ Show (Args m)+ ) =>+ f m ->+ m+ ) ->+ InterfaceOf f++ showLabel :: f m -> String++ compareLabel :: f m1 -> f m2 -> Ordering+ compareLabel x y = showLabel x `compare` showLabel y++-- | @f :|: g@ is the disjoint union of label @f@ and label @g@.+-- Use this type when you want to specify a protocol for multiple interfaces.+--+-- ==== Example+--+-- @+-- data FooService = FooService {+-- foo :: Int -> IO Bool,+-- ...+-- }+-- data BarService = BarService {+-- bar :: String -> IO (),+-- ...+-- }+-- deriveLabel ''FooService+-- deriveLabel ''BarService+--+-- proto :: ProtocolM (FooServiceLabel ':|:' BarServiceLabel) ()+-- proto = do+-- i1 <- decl $ whenArgs ('L' Foo) (==1) \`thenReturn\` True+-- void $ decl $ whenArgs ('R' Bar) (=="bar") \`thenReturn\` () \`dependsOn\` [i1]+--+-- main :: IO ()+-- main = withProtocol proto $ \\(fooService, barService) -> do+-- ...+-- @+data (:|:) f g a = L (f a) | R (g a)+ deriving (Eq, Ord, Show)++instance (Label f, Label g) => Label (f :|: g) where+ type InterfaceOf (f :|: g) = (InterfaceOf f, InterfaceOf g)+ toInterface k = (f, g)+ where+ f = toInterface (k . L)+ g = toInterface (k . R)+ showLabel (L x) = "L " <> showLabel x+ showLabel (R x) = "R " <> showLabel x++-- |+-- Generate the label type from given interface type.+--+-- * Define GADT @XXXLabel m@ for interface @XXX@.+--+-- * @FieldX :: XXXLabel X@ for each field @fieldX :: X@ where @X@ is a standard type.+-- * @PolyFieldX :: XXXLabel ty[Dynamic/a]@ for each field of the form @polyFieldX :: (forall a. Typeable a => ty)@+--+-- * Type variable @a@ is substituted with @DynamicShow@ if @a@ is instances of 'Show' and 'Typeable'+-- * Type variable @a@ is substituted with @Dynamic@ if @a@ is an instance of 'Typeable' but not 'Show'+-- * Report an error if type variable @a@ is not an instance of 'Typeable'+--+-- * Define instance @Label XXXLabel@.+--+-- ==== Example+--+-- @+-- data API env = API {+-- _foo :: Int -> RIO env Int,+-- _bar :: forall a. (Show a, Typeable a) => String -> RIO env (Maybe a),+-- _baz :: forall b. (Typeable a) => b -> RIO env ()+-- }+-- @+--+-- @deriveLabel ''API@ will generate the following code.+--+-- @+-- data APILabel env m where+-- Foo :: APILabel env (Int -> RIO env Int)+-- Bar :: APILabel env (String -> RIO env (Maybe DynamicShow)) -- type variable \`a\` is replaced with 'DynamicShow'+-- Baz :: APILabel env (Dynamic -> RIO env ()) -- type variable \'b\' is replaced with 'Dynamic'+--+-- instance Label (APILabel env) where+-- type InterfaceOf (APILabel env) = API env+-- toInterface k = API (k Foo) (castMethod (k Bar)) (castMethod (k Baz))+-- showLabel x = case x of+-- Foo -> "Foo"+-- Bar -> "Bar"+-- Baz -> "Baz"+-- @+deriveLabel :: Name -> DecsQ+deriveLabel name = do+ info <- D.reifyDatatype name+ tyVars <- mapM extractTyVar $ D.datatypeInstTypes info+ consInfo <- case D.datatypeCons info of+ [consInfo] -> pure consInfo+ _ -> fail $ "Multiple constructors: " <> pprint name+ fieldNames <- case D.constructorVariant consInfo of+ D.RecordConstructor names -> pure names+ _ -> fail $ "Constructor must be a record: " <> pprint (D.constructorName consInfo)+ labelConNames <- mapM fieldToLabel fieldNames+ let fields = D.constructorFields consInfo+ labelTy = foldl ((. VarT) . AppT) (ConT labelName) tyVarNames+ labelName = mkName $ (++ "Label") $ nameBase name+ tyVarNames = map bndrToName tyVars+ recordTy = D.datatypeType info+ recordConName = D.constructorName consInfo+ labelDec <- deriveLabelData (tyVars, fields, labelTy, labelName, labelConNames)+ labelInstDec <- deriveLabelInst (tyVars, labelTy, recordTy, recordConName, labelConNames)+ pure [labelDec, labelInstDec]++deriveLabelInst :: ([TyVarBndr], Type, Type, Name, [Name]) -> DecQ+deriveLabelInst (tyVars, labelTy, interfaceTy, interfaceConName, labelConNames) =+ instanceD (cxt cxts) (conT ''Label `appT` pure labelTy) [interfaceOfDec, toInterfaceDec, showLabelDec]+ where+ cxts = [conT ''Typeable `appT` varT n | n <- bndrToName <$> tyVars]+ interfaceOfDec = tySynInstD (tySynEqn Nothing (conT ''InterfaceOf `appT` pure labelTy) (pure interfaceTy))+ -- toInterface = \k -> API (castMethod $ k Foo) (castMethod $ k Bar) (castMethod $ k Baz)+ toInterfaceDec = valD (varP 'toInterface) (normalB bodyE) []+ where+ k = mkName "k"+ bodyE = lam1E (varP k) $ foldl step (conE interfaceConName) labelConNames+ step acc labelCon = acc `appE` appE (varE 'castMethod) (appE (varE k) (conE labelCon))+ showLabelDec = valD (varP 'showLabel) (normalB bodyE) []+ where+ x = mkName "x"+ bodyE = lam1E (varP x) (caseE (varE x) (map showCase labelConNames))+ showCase conName =+ match (conP conName []) (normalB $ stringE $ nameBase conName) []++-- |+-- @+-- data API env = API {+-- _foo :: RIO env Int,+-- _bar :: Text -> RIO env Bool,+-- }+-- >>>+-- data APILabel env m where+-- Foo :: APILabel env (RIO env Int)+-- Bar :: APILabel env (Text -> RIO env Bool)+-- @+deriveLabelData :: ([TyVarBndr], [Type], Type, Name, [Name]) -> Q Dec+deriveLabelData (tyVars, fields, labelTy, labelName, labelConNames) = do+ m <- newName "m"+ dataD (cxt []) labelName (tyVars ++ [PlainTV m]) Nothing consQ []+ where+ consQ = zipWith toLabel fields labelConNames+ -- $cName :: $labelName x1 ... xn $fieldTy+ toLabel fieldTy cName = gadtC [cName] [] (pure labelTy `appT` unquantify fieldTy)++unquantify :: Type -> Q Type+unquantify _ty@(ForallT bndrs ctx ty) = do+ tbl <- M.fromList <$> mapM (substBndr _ty ctx) bndrs+ subst tbl ty+unquantify ty = pure ty++substBndr :: Type -> [Pred] -> TyVarBndr -> Q (Name, Type)+substBndr ty preds = go . bndrToName+ where+ go n+ | (ConT ''Typeable `AppT` VarT n) `elem` preds+ && (ConT ''Show `AppT` VarT n) `elem` preds =+ pure (n, ConT ''DynamicShow)+ | (ConT ''Typeable `AppT` VarT n) `elem` preds = pure (n, ConT ''Dynamic)+ | otherwise =+ fail $+ "cannot unquantify: " <> pprint ty+ <> " because Typeable "+ <> pprint n+ <> " constraint is missing"++subst :: M.Map Name Type -> Type -> Q Type+subst tbl (VarT x) = case M.lookup x tbl of+ Just t -> pure t+ Nothing -> pure $ VarT x+subst tbl (AppT f x) = AppT <$> subst tbl f <*> subst tbl x+subst tbl (InfixT x op y) = InfixT <$> subst tbl x <*> pure op <*> subst tbl y+subst _ ArrowT = pure ArrowT+subst _ ty@ConT {} = pure ty+subst _ ty@TupleT {} = pure ty+subst _ ty@ListT = pure ty+subst _ ty@ForallT {} = fail $ "nested forall quantifier is not supported: " <> pprint ty+subst _ ty = fail $ "conversion for " <> pprint ty <> " is not implemented yet. Please raise an issue."++bndrToName :: TyVarBndr -> Name+bndrToName (PlainTV n) = n+bndrToName (KindedTV n _) = n++-- |+-- @+-- fieldToLabel (mkName "_hello") = pure (mkName \"Hello\")+-- @+fieldToLabel :: Name -> Q Name+fieldToLabel fieldName = toConName trimed+ where+ base = nameBase fieldName+ trimed = L.dropWhile (not . isLower) base+ toConName "" = fail $ "cannot convert field name to constructor name: " <> pprint fieldName+ toConName (x : xs) = pure $ mkName $ toUpper x : xs++extractTyVar :: Type -> Q TyVarBndr+extractTyVar (SigT (VarT x) k) = pure $ KindedTV x k+extractTyVar (VarT x) = pure $ PlainTV x+extractTyVar ty = fail $ "cannot extract type variable: " <> pprint ty
src/Test/Method/Protocol.hs view
@@ -24,7 +24,6 @@ Call, CallArgs, CallId,- IsMethodName, lookupMock, lookupMockWithShow, decl,@@ -34,25 +33,22 @@ thenReturn, dependsOn, verify,+ mockInterface,+ withProtocol, ) where import Control.Method ( Method (Args, Base, curryMethod, uncurryMethod),- TupleLike (AsTuple, toTuple), ) import Control.Monad.Trans.State.Strict (StateT, execStateT, state) import Data.Maybe (fromJust)-import Data.Typeable- ( Typeable,- cast,- typeOf,- ) import RIO (IORef, MonadIO (liftIO), Set, forM_, newIORef, on, readIORef, unless, writeIORef, (&)) import qualified RIO.List as L import qualified RIO.Map as M import qualified RIO.Set as S import Test.Method.Behavior (Behave (Condition, MethodOf, thenMethod), thenAction, thenReturn)+import Test.Method.Label (Label (InterfaceOf, compareLabel, showLabel, toInterface)) import Test.Method.Matcher (ArgsMatcher (EachMatcher, args), Matcher) import Unsafe.Coerce (unsafeCoerce) @@ -71,30 +67,24 @@ } data SomeCall f where- SomeCall :: IsMethodName f m => Call f m -> SomeCall f+ SomeCall :: Label f => Call f m -> SomeCall f data SomeMethodName f where- SomeMethodName :: IsMethodName f m => f m -> SomeMethodName f+ SomeMethodName :: Label f => f m -> SomeMethodName f instance Eq (SomeMethodName f) where- SomeMethodName x == SomeMethodName y =- case cast y of- Just y' -> x == y'- Nothing -> False+ SomeMethodName x == SomeMethodName y = compareLabel x y == EQ instance Ord (SomeMethodName f) where- compare (SomeMethodName x) (SomeMethodName y) =- compare (typeOf x) (typeOf y) <> case cast y of- Just y' -> compare x y'- Nothing -> LT+ compare (SomeMethodName x) (SomeMethodName y) = compareLabel x y instance Show (SomeMethodName f) where- show (SomeMethodName x) = show x+ show (SomeMethodName x) = showLabel x data MethodCallAssoc f where MethodCallAssoc :: forall f m.- (Typeable (f m), Show (f m)) =>+ (Label f) => { assocCalls :: [(CallId, Call f m)], assocCounter :: IORef Int } ->@@ -120,6 +110,16 @@ getMethodName :: SomeCall f -> SomeMethodName f getMethodName (SomeCall Call {argsSpec = CallArgs {methodName = name}}) = SomeMethodName name +-- | @withProtocol proto action@ executes @action@ with a mock interface+-- specified by @proto@, and then, it calls 'verify'.+withProtocol :: (Label f, MonadIO m) => ProtocolM f a -> (InterfaceOf f -> m b) -> m b+withProtocol p action = do+ env <- liftIO $ protocol p+ a <- action $ mockInterface env+ liftIO $ verify env+ pure a+{-# INLINEABLE withProtocol #-}+ -- | Build 'ProtocolEnv' from Protocol DSL. protocol :: ProtocolM f a -> IO (ProtocolEnv f) protocol (ProtocolM dsl) = do@@ -155,19 +155,21 @@ writeIORef ref (x + 1) pure x -type IsMethodName f m = (Typeable (f m), Ord (f m), Show (f m))+-- | Get the mock interface from ProtocolEnv+mockInterface :: (Label f) => ProtocolEnv f -> InterfaceOf f+mockInterface env = toInterface (`lookupMock` env) -- | Get the mock method by method name. -- Return a unstubed method (which throws exception for every call) -- if the behavior of the method is unspecified by ProtocolEnv lookupMock :: forall f m.- (IsMethodName f m, Show (AsTuple (Args m)), TupleLike (Args m), Method m, MonadIO (Base m)) =>+ (Label f, Show (Args m), Method m, MonadIO (Base m)) => -- | name of method f m -> ProtocolEnv f -> m-lookupMock = lookupMockWithShow (show . toTuple)+lookupMock = lookupMockWithShow show -- | Get the mock method by method name. -- Return a unstubed method (which throws exception for every call)@@ -176,7 +178,7 @@ -- show implementation for the argument of the method. lookupMockWithShow :: forall f m.- (IsMethodName f m, Method m, MonadIO (Base m)) =>+ (Label f, Method m, MonadIO (Base m)) => -- | show function for the argument of method (Args m -> String) -> -- | name of method@@ -187,18 +189,18 @@ case M.lookup (SomeMethodName name) methodEnv of Nothing -> curryMethod $ \_ -> error $- "0-th call of method " <> show name <> " is unspecified"+ "0-th call of method " <> showLabel name <> " is unspecified" Just MethodCallAssoc {assocCalls = assocCalls', ..} -> let assocCalls = unsafeCoerce assocCalls' :: [(CallId, Call f m)] in curryMethod $ \xs -> do i <- tick assocCounter unless (i < length assocCalls) $- error $ show i <> "-th call of method " <> show name <> " is unspecified"+ error $ show i <> "-th call of method " <> showLabel name <> " is unspecified" let (callId, Call {..}) = assocCalls !! i CallArgs {..} = argsSpec unless (argsMatcher xs) $ error $- "unexpected argument of " <> show i <> "-th call of method " <> show name <> ": "+ "unexpected argument of " <> show i <> "-th call of method " <> showLabel name <> ": " <> fshow xs calledIdSet <- liftIO $ readIORef calledIdSetRef forM_ dependCall $ \callId' -> do@@ -209,7 +211,7 @@ uncurryMethod retSpec xs -- | Declare a method call specification. It returns the call id of the method call.-decl :: (IsMethodName f m) => Call f m -> ProtocolM f CallId+decl :: (Label f) => Call f m -> ProtocolM f CallId decl call = ProtocolM $ state $ \(l, callId@(CallId i)) -> (callId, ((callId, SomeCall call) : l, CallId (i + 1)))
+ test/Test/Method/LabelSpec.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++--{-# OPTIONS_GHC -ddump-splices -ddump-simpl -ddump-to-file #-}++module Test.Method.LabelSpec where++import Data.Typeable (typeRep)+import RIO+ ( Display (textDisplay),+ Proxy (Proxy),+ RIO,+ Text,+ Typeable,+ displayShow,+ runRIO,+ )+import Test.Hspec (Spec, describe, it, shouldBe, shouldReturn)+import Test.Method.Label+ ( Label (toInterface),+ deriveLabel,+ type (:|:) (L, R),+ )++data API env = API+ { _foo :: RIO env Int,+ _bar :: Text -> RIO env Text,+ _baz :: forall a. Typeable a => (Int, Bool) -> RIO env [a]+ }++deriveLabel ''API++data FizzBuzz env = FizzBuzz+ { _fizz :: RIO env Text,+ _buzz :: RIO env Text,+ _others :: forall a. (Show a, Typeable a) => a -> RIO env Text+ }++deriveLabel ''FizzBuzz++spec :: Spec+spec = do+ describe "deriveLabel ''API" $ do+ describe "APILabel" $ do+ it "Foo is defined" $ do+ typeRep (Foo @()) `shouldBe` typeRep (Proxy :: Proxy (RIO () Int))+ it "Bar is defined" $ do+ typeRep (Bar @()) `shouldBe` typeRep (Proxy :: Proxy (Text -> RIO () Text))+ describe "toRecord" $ do+ let api = toInterface mock+ it "_foo api returns 0" $ do+ runRIO () (_foo api) `shouldReturn` 0+ it "_bar api \"hello\" returns \"hello hoge\"" $ do+ runRIO () (_bar api "hello") `shouldReturn` "hello hoge"+ describe "(:|:)" $ do+ let (api, fizzbuzz) = toInterface mock2+ it "_foo api returns 1" $ do+ runRIO () (_foo api) `shouldReturn` 1+ it "_fizz fizzbuzz returns \"Fizz\"" $ do+ runRIO () (_fizz fizzbuzz) `shouldReturn` "Fizz"+ it "_others fizzbuzz 10 returns \"<<10 :: Int>>\"" $ do+ runRIO () (_others fizzbuzz (10 :: Int)) `shouldReturn` "<<10 :: Int>>"++mock :: APILabel env m -> m+mock Foo = pure 0+mock Bar = \x -> pure (x <> " hoge")+mock Baz = undefined++mock2 :: (:|:) (APILabel env) (FizzBuzzLabel env) m -> m+mock2 (L Foo) = pure 1+mock2 (L Bar) = \x -> pure (x <> " bar")+mock2 (L Baz) = undefined+mock2 (R Fizz) = pure "Fizz"+mock2 (R Buzz) = pure "Buzz"+mock2 (R Others) = pure . textDisplay . displayShow
test/Test/Method/ProtocolSpec.hs view
@@ -1,7 +1,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} module Test.Method.ProtocolSpec where @@ -16,24 +19,33 @@ shouldReturn, shouldThrow, )+import Test.Method.Dynamic (ToDyn (toDyn), Typeable, dynArg)+import Test.Method.Label (deriveLabel) import Test.Method.Protocol ( ProtocolM, decl, dependsOn,- lookupMock,+ mockInterface, protocol, thenReturn, verify, whenArgs,+ withProtocol, ) -data Methods m where- FindUser :: Methods (UserName -> IO (Maybe User))- FindPassword :: Methods (UserName -> IO (Maybe HashedPassword))- CreateUser :: Methods (UserName -> IO User)- HashPassword :: Methods (PlainPassword -> IO HashedPassword)- UpsertAuth :: Methods (UserId -> HashedPassword -> IO ())+type UserName = Text +type PlainPassword = ByteString++type HashedPassword = ByteString++type UserId = Int++data Env = Env++data User = User {userName :: UserName, userId :: UserId}+ deriving (Eq, Ord, Show)+ data Service = Service { findUser :: UserName -> IO (Maybe User), findPassword :: UserName -> IO (Maybe HashedPassword),@@ -42,6 +54,8 @@ upsertAuth :: UserId -> HashedPassword -> IO () } +deriveLabel ''Service+ doService :: Service -> UserName -> PlainPassword -> IO (Maybe User) doService Service {..} usernm passwd = do mUser <- findUser usernm@@ -119,31 +133,36 @@ upsertAuth (userId user) hpasswd pure $ Just user -serviceProtocol :: UserName -> PlainPassword -> HashedPassword -> UserId -> ProtocolM Methods ()+serviceProtocol :: UserName -> PlainPassword -> HashedPassword -> UserId -> ProtocolM ServiceLabel () serviceProtocol usernm passwd hpasswd userid = do i1 <- decl $ whenArgs FindUser (== usernm) `thenReturn` Nothing i2 <- decl $ whenArgs CreateUser (== usernm) `thenReturn` User usernm userid `dependsOn` [i1] i3 <- decl $ whenArgs HashPassword (== passwd) `thenReturn` hpasswd void $ decl $ whenArgs UpsertAuth ((== userid), (== hpasswd)) `thenReturn` () `dependsOn` [i2, i3] -deriving instance (Show (Methods m))--deriving instance (Eq (Methods m))--deriving instance (Ord (Methods m))--type UserName = Text--type PlainPassword = ByteString--type HashedPassword = ByteString+data DBService = DBService+ { query :: forall a. (Typeable a, Show a) => String -> IO [a],+ execute :: forall a. (Typeable a, Show a) => String -> a -> IO ()+ } -type UserId = Int+deriveLabel ''DBService -data Env = Env+dbProtocol :: ProtocolM DBServiceLabel ()+dbProtocol = do+ i1 <-+ decl $+ whenArgs Query (== "SELECT user_id FROM user")+ `thenReturn` toDyn [1, 2, 3 :: Int]+ _ <-+ decl $+ whenArgs Execute ((== "INSERT INTO friend(user_id, other_id) VALUES (?,?)"), dynArg (== (1 :: Int, 2 :: Int)))+ `thenReturn` () `dependsOn` [i1]+ pure () -data User = User {userName :: UserName, userId :: UserId}- deriving (Eq, Ord, Show)+doDBService :: DBService -> IO ()+doDBService DBService {..} = do+ (user1 : user2 : _) <- query "SELECT user_id FROM user"+ execute "INSERT INTO friend(user_id, other_id) VALUES (?,?)" (user1, user2 :: Int) spec :: Spec spec = describe "protocol" $ do@@ -153,16 +172,7 @@ userid = 0 let setup = do penv <- protocol $ serviceProtocol usernm passwd hpasswd userid- pure- ( penv,- Service- { findUser = lookupMock FindUser penv,- findPassword = lookupMock FindPassword penv,- createUser = lookupMock CreateUser penv,- hashPassword = lookupMock HashPassword penv,- upsertAuth = lookupMock UpsertAuth penv- }- )+ pure (penv, mockInterface penv) before setup $ do context "accept valid impl" $ do it "accept valid impl findUser first" $ \(penv, service) -> do@@ -183,3 +193,7 @@ doServiceWrongOrder service usernm passwd `shouldThrow` anyErrorCall it "unspecified method call" $ \(_, service) -> do doServiceWrongUnspecifiedMethod service usernm passwd `shouldThrow` anyErrorCall+ context "dbservice" $ do+ it "mock polymorphic interface" $ do+ withProtocol dbProtocol $ \svc ->+ doDBService svc `shouldReturn` ()