diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/method.cabal b/method.cabal --- a/method.cabal +++ b/method.cabal @@ -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 diff --git a/src/Control/Method/Internal.hs b/src/Control/Method/Internal.hs --- a/src/Control/Method/Internal.hs +++ b/src/Control/Method/Internal.hs @@ -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 :* diff --git a/src/Test/Method.hs b/src/Test/Method.hs --- a/src/Test/Method.hs +++ b/src/Test/Method.hs @@ -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: diff --git a/src/Test/Method/Dynamic.hs b/src/Test/Method/Dynamic.hs --- a/src/Test/Method/Dynamic.hs +++ b/src/Test/Method/Dynamic.hs @@ -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 = diff --git a/src/Test/Method/Label.hs b/src/Test/Method/Label.hs new file mode 100644 --- /dev/null +++ b/src/Test/Method/Label.hs @@ -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 diff --git a/src/Test/Method/Protocol.hs b/src/Test/Method/Protocol.hs --- a/src/Test/Method/Protocol.hs +++ b/src/Test/Method/Protocol.hs @@ -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))) diff --git a/test/Test/Method/LabelSpec.hs b/test/Test/Method/LabelSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Method/LabelSpec.hs @@ -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 diff --git a/test/Test/Method/ProtocolSpec.hs b/test/Test/Method/ProtocolSpec.hs --- a/test/Test/Method/ProtocolSpec.hs +++ b/test/Test/Method/ProtocolSpec.hs @@ -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` ()