packages feed

fixie (empty) → 0.0.0

raw patch · 13 files changed

+1296/−0 lines, 13 filesdep +basedep +containersdep +data-default-classsetup-changed

Dependencies added: base, containers, data-default-class, either, fixie, haskell-src-exts, haskell-src-meta, hspec, hspec-discover, mtl, template-haskell, text, th-orphans, transformers

Files

+ CHANGELOG.md view
@@ -0,0 +1,9 @@+# 0.5.0.0 (November 28, 2016)++  - **Breaking**: `mkFixture` now supports constraints in the same form as a Haskell `deriving` clause, which permits “partially-applied” constraints. A new `ts` quasiquoter is provided for the purpose of writing a comma-separated list of Haskell types; see the documentation for more details ([#25](https://github.com/cjdev/test-fixture/issues/25)).+  - Generating fixtures that do not derive any typeclasses no longer produces an error ([#28](https://github.com/cjdev/test-fixture/issues/28)).++# 0.4.2.0 (November 14, 2016)++  - Attempting to generate a fixture for a multi-parameter typeclass now produces a better error message ([#24](https://github.com/cjdev/test-fixture/issues/24)).+  - Fixtures can now be generated for typeclasses containing infix operators as methods. They will be prefixed with a tilde (`~`) instead of an underscore ([#26](https://github.com/cjdev/test-fixture/issues/26)).
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright CJ Affiliate by Conversant (c) 2016,+          Joe Vargas (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of CJ Affiliate by Conversant nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,2 @@+# fixie [![Build Status](https://travis-ci.org/jxv/fixie.svg?branch=master)](https://travis-ci.org/jxv/fixie)+[fixie-hackage]: http://hackage.haskell.org/package/fixie
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ fixie.cabal view
@@ -0,0 +1,76 @@+name:+  fixie+version:+  0.0.0+synopsis:+  Opininated testing framework for mtl style (spies, stubs, and mocks)+description:+  Please see README.md+homepage:+  http://github.com/jxv/fixie#readme+license:+  BSD3+license-file:+  LICENSE+author:+  Joe Vargas+maintainer:+  joevargas92@gmail.com+copyright:+  2016 CJ Affiliate by Conversant, 2016 Joe Vargas+category:+  Test+build-type:+  Simple+extra-source-files:+  CHANGELOG.md+  LICENSE+  README.md+cabal-version:+   >=1.10++library+  hs-source-dirs: src+  default-language: Haskell2010+  ghc-options: -Wall+  exposed-modules:+    Test.Fixie+    Test.Fixie.Internal+    Test.Fixie.TH+    Test.Fixie.TH.Internal+    Test.Fixie.TH.Internal.TypesQuasi+  build-depends:+      base >= 4.7 && < 5+    , containers+    , data-default-class+    , either+    , haskell-src-exts+    , haskell-src-meta+    , mtl+    , template-haskell >= 2.10 && < 2.12+    , text+    , th-orphans++source-repository head+  type:+    git+  location:+    https://github.com/jxv/fixie++test-suite fixie-test-suite+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  default-language: Haskell2010+  ghc-options: -Wall+  other-modules:+    Test.Test.FixieSpec+    Test.Test.Fixie.THSpec+  build-depends:+      base >= 4.7 && < 5+    , fixie+    , hspec+    , hspec-discover+    , mtl+    , template-haskell >= 2.10 && < 2.12+    , transformers
+ src/Test/Fixie.hs view
@@ -0,0 +1,5 @@+module Test.Fixie+  ( module Test.Fixie.Internal+  ) where++import Test.Fixie.Internal hiding (Call(..), captureCall, getFixture, getFunction)
+ src/Test/Fixie/Internal.hs view
@@ -0,0 +1,514 @@+{-# OPTIONS_HADDOCK hide, not-home #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}++module Test.Fixie.Internal+  ( Note(..)+  , Function(..)+  , Call(..)+  , FixieT+  , FixieM+  , toSet+  , note+  , getFixture+  , getFunction+  , captureCall+  , unimplemented+  , outputNotesFunctionsT+  , outputNotesFunctionsetT+  , outputFunctionsNotesT+  , outputFunctionsetNotesT+  , valueNotesFunctionsT+  , valueNotesFunctionsetT+  , valueFunctionsNotesT+  , valueFunctionsetNotesT+  , notesOutputFunctionsT+  , notesOutputFunctionsetT+  , notesValueFunctionsT+  , notesValueFunctionsetT+  , notesFunctionsOutputT+  , notesFunctionsetOutputT+  , notesFunctionsValueT+  , notesFunctionsetValueT+  , functionsOutputNotesT+  , functionsValueNotesT+  , functionsNotesOutputT+  , functionsNotesValueT+  , functionsetOutputNotesT+  , functionsetValueNotesT+  , functionsetNotesOutputT+  , functionsetNotesValueT+  , outputNotesT+  , outputFunctionsT+  , outputFunctionsetT+  , valueNotesT+  , valueFunctionsT+  , valueFunctionsetT+  , notesOutputT+  , notesValueT+  , notesFunctionsT+  , notesFunctionsetT+  , functionsOutputT+  , functionsValueT+  , functionsNotesT+  , functionsetOutputT+  , functionsetValueT+  , functionsetNotesT+  , outputT+  , valueT+  , notesT+  , functionsT+  , functionsetT+  , outputNotesFunctionsM+  , outputNotesFunctionsetM+  , outputFunctionsNotesM+  , outputFunctionsetNotesM+  , valueNotesFunctionsM+  , valueNotesFunctionsetM+  , valueFunctionsNotesM+  , valueFunctionsetNotesM+  , notesOutputFunctionsM+  , notesOutputFunctionsetM+  , notesValueFunctionsM+  , notesValueFunctionsetM+  , notesFunctionsOutputM+  , notesFunctionsetOutputM+  , notesFunctionsValueM+  , notesFunctionsetValueM+  , functionsOutputNotesM+  , functionsValueNotesM+  , functionsNotesOutputM+  , functionsNotesValueM+  , functionsetOutputNotesM+  , functionsetValueNotesM+  , functionsetNotesOutputM+  , functionsetNotesValueM+  , outputNotesM+  , outputFunctionsM+  , outputFunctionsetM+  , valueNotesM+  , valueFunctionsM+  , valueFunctionsetM+  , notesOutputM+  , notesValueM+  , notesFunctionsM+  , notesFunctionsetM+  , functionsOutputM+  , functionsValueM+  , functionsNotesM+  , functionsetOutputM+  , functionsetValueM+  , functionsetNotesM+  , outputM+  , valueM+  , notesM+  , functionsM+  , functionsetM+  ) where++import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.Writer+import Data.Functor.Identity+import Data.String (IsString)+import Data.Set (Set)+import qualified Data.Set as Set (fromList)+import Data.Either.Combinators (fromRight')+import Data.Text (Text, pack)+import Data.Void (Void)++newtype Note = Note Text+  deriving (Show, Eq, IsString)++newtype Function = Function Text+  deriving (Show, Eq, Ord, IsString)++newtype Call = Call { _function :: Function }+  deriving (Show, Eq, Ord)++newtype FixieT f e m a = FixieT (ExceptT e (ReaderT (f (FixieT f e m)) (WriterT [Note] (WriterT [Call] m))) a)+  deriving (Functor, Applicative, Monad)++instance Monad m => MonadError e (FixieT f e m) where+  throwError e = do+    captureCall $ Call $ Function (pack "throwError")+    FixieT $ throwError e+  catchError (FixieT a) b = do+    captureCall $ Call $ Function (pack "catchError")+    FixieT $ catchError a ((\(FixieT c) -> c) . b)++instance MonadTrans (FixieT f e) where+  lift = FixieT . lift . lift . lift . lift++type FixieM f e = FixieT f e Identity++--++unimplemented :: String -> a+unimplemented name = error ("unimplemented fixture method `" ++ name ++ "`")++toSet :: Ord a => [a] -> Set a+toSet = Set.fromList++--++getFixture :: Monad m => FixieT f e m (f (FixieT f e m))+getFixture = FixieT $ lift ask++getFunction :: Monad m => (f (FixieT f e m) -> a) -> FixieT f e m a+getFunction f = FixieT $ lift (asks f)++note :: Monad m => Note -> FixieT f e m ()+note = FixieT . lift . lift . tell . (:[])++captureCall :: Monad m => Call -> FixieT f e m ()+captureCall = FixieT . lift . lift . lift . tell . (:[])++--++noVoid :: Either Void a -> a+noVoid = fromRight'++pluck :: (a, b, c) -> (a, b)+pluck (a, b, _) = (a, b)++swap_0_2_1 :: (a, b, c) -> (a, c, b)+swap_0_2_1 (a, b, c) = (a, c, b)++swap_1_0_2 :: (a, b, c) -> (b, a, c)+swap_1_0_2 (a, b, c) = (b, a, c)++swap_1_2_0 :: (a, b, c) -> (b, c, a)+swap_1_2_0 (a, b, c) = (b, c, a)++swap_2_0_1 :: (a, b, c) -> (c, a, b)+swap_2_0_1 (a, b, c) = (c, a, b)++swap_2_1_0 :: (a, b, c) -> (c, b, a)+swap_2_1_0 (a, b, c) = (c, b, a)++map_0 :: (a -> d) -> (a, b, c) -> (d, b, c)+map_0 f (a, b, c) = (f a, b, c)++map_1 :: (b -> d) -> (a, b, c) -> (a, d, c)+map_1 f (a, b, c) = (a, f b, c)++map_2 :: (c -> d) -> (a, b, c) -> (a, b, d)+map_2 f (a, b, c) = (a, b, f c)++--++outputNotesCalls :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m (Either e a, [Note], [Call])+outputNotesCalls f (FixieT m) = fmap flattenTuple $ runWriterT $ runWriterT $ runReaderT (runExceptT m) f+  where+    flattenTuple :: ((a, b), c) -> (a, b, c)+    flattenTuple ((a, b), c) = (a, b, c)++--++valueNotesCalls :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m (a, [Note], [Call])+valueNotesCalls f x = strip <$> outputNotesCalls f x+  where+    strip :: (Either Void a, b, c) -> (a, b, c) +    strip (a, b, c) = (noVoid a, b, c)++--++outputNotesFunctions :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m (Either e a, [Note], [Function])+outputNotesFunctions f x = fn <$> outputNotesCalls f x+  where+    fn :: (Either e a, [Note], [Call]) -> (Either e a, [Note], [Function])+    fn (a, b, c) = (a, b, map _function c)++valueNotesFunctions :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m (a, [Note], [Function])+valueNotesFunctions f x = fn <$> valueNotesCalls f x+  where+    fn :: (a, b, [Call]) -> (a, b, [Function]) +    fn (a, b, c) = (a, b, map _function c)++----++outputNotesFunctionsT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m (Either e a, [Note], [Function])+outputNotesFunctionsT = outputNotesFunctions++outputNotesFunctionsetT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m (Either e a, [Note], Set Function)+outputNotesFunctionsetT f x = map_2 toSet <$>  outputNotesFunctions f x++outputFunctionsNotesT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m (Either e a, [Function], [Note])+outputFunctionsNotesT f x = swap_0_2_1 <$> outputNotesFunctions f x++outputFunctionsetNotesT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m (Either e a, Set Function, [Note])+outputFunctionsetNotesT f x = map_1 toSet . swap_0_2_1 <$> outputNotesFunctions f x++valueNotesFunctionsT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m (a, [Note], [Function])+valueNotesFunctionsT = valueNotesFunctions++valueNotesFunctionsetT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m (a, [Note], Set Function)+valueNotesFunctionsetT f x = map_2 toSet <$> valueNotesFunctions f x++valueFunctionsNotesT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m (a, [Function], [Note])+valueFunctionsNotesT f x = swap_0_2_1 <$> valueNotesFunctions f x++valueFunctionsetNotesT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m (a, Set Function, [Note])+valueFunctionsetNotesT f x = map_1 toSet . swap_0_2_1 <$> valueNotesFunctions f x++--++notesOutputFunctionsT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m ([Note], Either e a, [Function])+notesOutputFunctionsT f x = swap_1_0_2 <$> outputNotesFunctions f x++notesOutputFunctionsetT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m ([Note], Either e a, Set Function)+notesOutputFunctionsetT f x = map_2 toSet . swap_1_0_2 <$> outputNotesFunctions f x++notesValueFunctionsT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m ([Note], a, [Function])+notesValueFunctionsT f x = swap_1_0_2 <$> valueNotesFunctions f x++notesValueFunctionsetT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m ([Note], a, Set Function)+notesValueFunctionsetT f x = map_2 toSet . swap_1_0_2 <$> valueNotesFunctions f x++notesFunctionsOutputT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m ([Note], [Function], Either e a)+notesFunctionsOutputT f x = swap_1_2_0 <$> outputNotesFunctions f x++notesFunctionsetOutputT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m ([Note], Set Function,  Either e a)+notesFunctionsetOutputT f x = map_1 toSet . swap_1_2_0 <$> outputNotesFunctions f x++notesFunctionsValueT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m ([Note], [Function], a)+notesFunctionsValueT f x = swap_1_2_0 <$> valueNotesFunctions f x++notesFunctionsetValueT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m ([Note], Set Function, a)+notesFunctionsetValueT f x = map_1 toSet . swap_1_2_0 <$> valueNotesFunctions f x++functionsOutputNotesT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m ([Function], Either e a, [Note])+functionsOutputNotesT f x = swap_2_0_1 <$> outputNotesFunctions f x++functionsValueNotesT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m ([Function], a, [Note])+functionsValueNotesT f x = swap_2_0_1 <$> valueNotesFunctions f x++functionsNotesOutputT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m ([Function], [Note], Either e a)+functionsNotesOutputT f x = swap_2_1_0 <$> outputNotesFunctions f x++functionsNotesValueT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m ([Function], [Note], a)+functionsNotesValueT f x = swap_2_1_0 <$> valueNotesFunctions f x++functionsetOutputNotesT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m (Set Function, Either e a, [Note])+functionsetOutputNotesT f x = map_0 toSet . swap_2_0_1 <$> outputNotesFunctions f x++functionsetValueNotesT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m (Set Function, a, [Note])+functionsetValueNotesT f x = map_0 toSet . swap_2_0_1 <$> valueNotesFunctions f x++functionsetNotesOutputT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m (Set Function, [Note], Either e a)+functionsetNotesOutputT f x = map_0 toSet . swap_2_1_0 <$> outputNotesFunctions f x++functionsetNotesValueT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m (Set Function, [Note], a)+functionsetNotesValueT f x = map_0 toSet . swap_2_1_0 <$> valueNotesFunctions f x++--++outputNotesT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m (Either e a, [Note])+outputNotesT f x = pluck <$> outputNotesFunctions f x++outputFunctionsT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m (Either e a, [Function])+outputFunctionsT f x = pluck . swap_0_2_1 <$> outputNotesFunctions f x++outputFunctionsetT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m (Either e a, Set Function)+outputFunctionsetT f x = pluck . map_1 toSet . swap_0_2_1 <$> outputNotesFunctions f x++valueNotesT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m (a, [Note])+valueNotesT f x = pluck <$> valueNotesFunctions f x++valueFunctionsT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m (a, [Function])+valueFunctionsT f x = pluck . swap_0_2_1 <$> valueNotesFunctions f x++valueFunctionsetT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m (a, Set Function)+valueFunctionsetT f x = pluck . map_1 toSet . swap_0_2_1 <$> valueNotesFunctions f x++notesOutputT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m ([Note], Either e a)+notesOutputT f x = pluck . swap_1_0_2 <$> outputNotesFunctions f x++notesValueT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m ([Note], a)+notesValueT f x = pluck . swap_1_0_2 <$> valueNotesFunctions f x++notesFunctionsT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m ([Note], [Function])+notesFunctionsT f x = pluck . swap_1_2_0 <$> outputNotesFunctions f x++notesFunctionsetT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m ([Note], Set Function)+notesFunctionsetT f x = pluck . map_1 toSet . swap_1_2_0 <$> outputNotesFunctions f x++functionsOutputT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m ([Function], Either e a)+functionsOutputT f x = pluck . swap_2_0_1 <$> outputNotesFunctions f x++functionsValueT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m ([Function], a)+functionsValueT f x = pluck . swap_2_0_1 <$> valueNotesFunctions f x++functionsNotesT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m ([Function], [Note])+functionsNotesT f x = pluck . swap_2_1_0 <$> outputNotesFunctions f x++functionsetOutputT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m (Set Function, Either e a)+functionsetOutputT f x = pluck . map_0 toSet . swap_2_0_1 <$> outputNotesFunctions f x++functionsetValueT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m (Set Function, a)+functionsetValueT f x = pluck . map_0 toSet . swap_2_0_1 <$> valueNotesFunctions f x++functionsetNotesT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m (Set Function, [Note])+functionsetNotesT f x = pluck . map_0 toSet . swap_2_1_0 <$> outputNotesFunctions f x++outputT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m (Either e a)+outputT f x = (\(a,_,_) -> a) <$> outputNotesFunctions f x++valueT :: Monad m => f (FixieT f Void m) -> FixieT f Void m a -> m a+valueT f x = (\(a,_,_) -> a) <$> valueNotesFunctions f x++notesT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m [Note]+notesT f x = (\(_,b,_) -> b) <$> outputNotesFunctions f x++functionsT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m [Function]+functionsT f x = (\(_,_,c) -> c) <$> outputNotesFunctions f x++functionsetT :: Monad m => f (FixieT f e m) -> FixieT f e m a -> m (Set Function)+functionsetT f x = (\(_,_,c) -> toSet c) <$> outputNotesFunctions f x++--------++fixieM :: (a -> b -> Identity c) -> a -> b -> c+fixieM y f x = runIdentity (y f x)++outputNotesFunctionsM :: f (FixieM f e) -> FixieM f e a -> (Either e a, [Note], [Function])+outputNotesFunctionsM = fixieM outputNotesFunctionsT ++outputNotesFunctionsetM :: f (FixieM f e) -> FixieM f e a -> (Either e a, [Note], Set Function)+outputNotesFunctionsetM = fixieM outputNotesFunctionsetT++outputFunctionsNotesM :: f (FixieM f e) -> FixieM f e a -> (Either e a, [Function], [Note])+outputFunctionsNotesM = fixieM outputFunctionsNotesT++outputFunctionsetNotesM :: f (FixieM f e) -> FixieM f e a -> (Either e a, Set Function, [Note])+outputFunctionsetNotesM = fixieM outputFunctionsetNotesT++valueNotesFunctionsM :: f (FixieM f Void) -> FixieM f Void a -> (a, [Note], [Function])+valueNotesFunctionsM = fixieM valueNotesFunctionsT++valueNotesFunctionsetM :: f (FixieM f Void) -> FixieM f Void a -> (a, [Note], Set Function)+valueNotesFunctionsetM = fixieM valueNotesFunctionsetT++valueFunctionsNotesM :: f (FixieM f Void) -> FixieM f Void a -> (a, [Function], [Note])+valueFunctionsNotesM = fixieM valueFunctionsNotesT++valueFunctionsetNotesM :: f (FixieM f Void) -> FixieM f Void a -> (a, Set Function, [Note])+valueFunctionsetNotesM = fixieM valueFunctionsetNotesT++notesOutputFunctionsM :: f (FixieM f e) -> FixieM f e a -> ([Note], Either e a, [Function])+notesOutputFunctionsM = fixieM notesOutputFunctionsT++notesOutputFunctionsetM :: f (FixieM f e) -> FixieM f e a -> ([Note], Either e a, Set Function)+notesOutputFunctionsetM = fixieM notesOutputFunctionsetT++notesValueFunctionsM :: f (FixieM f Void) -> FixieM f Void a -> ([Note], a, [Function])+notesValueFunctionsM = fixieM notesValueFunctionsT++notesValueFunctionsetM :: f (FixieM f Void) -> FixieM f Void a -> ([Note], a, Set Function)+notesValueFunctionsetM = fixieM notesValueFunctionsetT++notesFunctionsOutputM :: f (FixieM f e) -> FixieM f e a -> ([Note], [Function], Either e a)+notesFunctionsOutputM = fixieM notesFunctionsOutputT++notesFunctionsetOutputM :: f (FixieM f e) -> FixieM f e a -> ([Note], Set Function,  Either e a)+notesFunctionsetOutputM = fixieM notesFunctionsetOutputT++notesFunctionsValueM :: f (FixieM f Void) -> FixieM f Void a -> ([Note], [Function], a)+notesFunctionsValueM = fixieM notesFunctionsValueT++notesFunctionsetValueM :: f (FixieM f Void) -> FixieM f Void a -> ([Note], Set Function, a)+notesFunctionsetValueM = fixieM notesFunctionsetValueT++functionsOutputNotesM :: f (FixieM f e) -> FixieM f e a -> ([Function], Either e a, [Note])+functionsOutputNotesM = fixieM functionsOutputNotesT++functionsValueNotesM :: f (FixieM f Void) -> FixieM f Void a -> ([Function], a, [Note])+functionsValueNotesM = fixieM functionsValueNotesT++functionsNotesOutputM :: f (FixieM f e) -> FixieM f e a -> ([Function], [Note], Either e a)+functionsNotesOutputM = fixieM functionsNotesOutputT++functionsNotesValueM :: f (FixieM f Void) -> FixieM f Void a -> ([Function], [Note], a)+functionsNotesValueM = fixieM functionsNotesValueT++functionsetOutputNotesM :: f (FixieM f e) -> FixieM f e a -> (Set Function, Either e a, [Note])+functionsetOutputNotesM = fixieM functionsetOutputNotesT++functionsetValueNotesM :: f (FixieM f Void) -> FixieM f Void a -> (Set Function, a, [Note])+functionsetValueNotesM = fixieM functionsetValueNotesT++functionsetNotesOutputM :: f (FixieM f e) -> FixieM f e a -> (Set Function, [Note], Either e a)+functionsetNotesOutputM = fixieM functionsetNotesOutputT++functionsetNotesValueM :: f (FixieM f Void) -> FixieM f Void a -> (Set Function, [Note], a)+functionsetNotesValueM = fixieM functionsetNotesValueT++outputNotesM :: f (FixieM f e) -> FixieM f e a -> (Either e a, [Note])+outputNotesM = fixieM outputNotesT++outputFunctionsM :: f (FixieM f e) -> FixieM f e a -> (Either e a, [Function])+outputFunctionsM = fixieM outputFunctionsT++outputFunctionsetM :: f (FixieM f e) -> FixieM f e a -> (Either e a, Set Function)+outputFunctionsetM = fixieM outputFunctionsetT++valueNotesM :: f (FixieM f Void) -> FixieM f Void a -> (a, [Note])+valueNotesM = fixieM valueNotesT++valueFunctionsM :: f (FixieM f Void) -> FixieM f Void a -> (a, [Function])+valueFunctionsM = fixieM valueFunctionsT++valueFunctionsetM :: f (FixieM f Void) -> FixieM f Void a -> (a, Set Function)+valueFunctionsetM = fixieM valueFunctionsetT++notesOutputM :: f (FixieM f e) -> FixieM f e a -> ([Note], Either e a)+notesOutputM = fixieM notesOutputT++notesValueM :: f (FixieM f Void) -> FixieM f Void a -> ([Note], a)+notesValueM = fixieM notesValueT++notesFunctionsM :: f (FixieM f e) -> FixieM f e a -> ([Note], [Function])+notesFunctionsM = fixieM notesFunctionsT++notesFunctionsetM :: f (FixieM f e) -> FixieM f e a -> ([Note], Set Function)+notesFunctionsetM = fixieM notesFunctionsetT++functionsOutputM :: f (FixieM f e) -> FixieM f e a -> ([Function], Either e a)+functionsOutputM = fixieM functionsOutputT++functionsValueM :: f (FixieM f Void) -> FixieM f Void a -> ([Function], a)+functionsValueM = fixieM functionsValueT++functionsNotesM :: f (FixieM f e) -> FixieM f e a -> ([Function], [Note])+functionsNotesM = fixieM functionsNotesT++functionsetOutputM :: f (FixieM f e) -> FixieM f e a -> (Set Function, Either e a)+functionsetOutputM = fixieM functionsetOutputT++functionsetValueM :: f (FixieM f Void) -> FixieM f Void a -> (Set Function, a)+functionsetValueM = fixieM functionsetValueT++functionsetNotesM :: f (FixieM f e) -> FixieM f e a -> (Set Function, [Note])+functionsetNotesM = fixieM functionsetNotesT++outputM :: f (FixieM f e) -> FixieM f e a -> (Either e a)+outputM = fixieM outputT++valueM :: f (FixieM f Void) -> FixieM f Void a -> a+valueM = fixieM valueT++notesM :: f (FixieM f e) -> FixieM f e a -> [Note]+notesM = fixieM notesT++functionsM :: f (FixieM f e) -> FixieM f e a -> [Function]+functionsM = fixieM functionsT++functionsetM :: f (FixieM f e) -> FixieM f e a -> (Set Function)+functionsetM = fixieM functionsetT
+ src/Test/Fixie/TH.hs view
@@ -0,0 +1,9 @@+module Test.Fixie.TH+  ( mkFixture+  , def+  , ts+  ) where++import Test.Fixie.TH.Internal (mkFixture)+import Test.Fixie.TH.Internal.TypesQuasi (ts)+import Data.Default.Class (def)
+ src/Test/Fixie/TH/Internal.hs view
@@ -0,0 +1,376 @@+{-# OPTIONS_HADDOCK hide, not-home #-}++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++module Test.Fixie.TH.Internal where++import qualified Control.Monad.Fail as Fail++import Prelude hiding (log)+import Control.Monad (join, replicateM, when, zipWithM)+import Test.Fixie.Internal (FixieT, Call(..), Function(..), unimplemented, captureCall, getFunction)+import Data.Char (isPunctuation, isSymbol)+import Data.Default.Class (Default(..))+import Data.List (foldl', nub, partition)+import Data.Text (pack)+import GHC.Exts (Constraint)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax++{-|+  A Template Haskell function that generates a fixture record type with a given+  name that reifies the set of typeclass dictionaries provided, as described in+  the module documentation for "Control.Monad.Fixie.TH". For example, the+  following splice would create a new record type called @Fixture@ with fields+  and instances for typeclasses called @Foo@ and @Bar@:++  > mkFixture "Fixture" [ts| Foo, Bar |]++  'mkFixture' supports types in the same format that @deriving@ clauses do when+  used with the @GeneralizedNewtypeDeriving@ GHC extension, so deriving+  multi-parameter typeclasses is possible if they are partially applied. For+  example, the following is valid:++  > class MultiParam a m where+  >   doSomething :: a -> m ()+  >+  > mkFixture "Fixture" [ts| MultiParam String |]+-}+mkFixture :: String -> [Type] -> Q [Dec]+mkFixture fixtureNameStr classTypes = do+  let fixtureName = mkName fixtureNameStr+  mapM_ assertDerivableConstraint classTypes++  (fixtureDec, fixtureFields) <- mkFixtureRecord fixtureName classTypes+  defaultInstanceDec <- mkDefaultInstance fixtureName fixtureFields++  instanceDecs <- traverse (flip mkInstance fixtureName) classTypes++  return ([fixtureDec, defaultInstanceDec] ++ instanceDecs)++mkFixtureRecord :: Name -> [Type] -> Q (Dec, [VarStrictType])+mkFixtureRecord fixtureName classTypes = do+  let classNames = map unappliedTypeName classTypes+  info <- traverse reify classNames+  methods <- traverse classMethods info++  mVar <- newName "m"+  fixtureFields <- join <$> zipWithM (methodsToFields mVar) classTypes methods+  let fixtureCs = [RecC fixtureName fixtureFields]++  let mKind = AppT (AppT ArrowT StarT) StarT+  let fixtureDec = mkDataD [] fixtureName [KindedTV mVar mKind] fixtureCs+  return (fixtureDec, fixtureFields)++mkDefaultInstance :: Name -> [VarStrictType] -> Q Dec+mkDefaultInstance fixtureName fixtureFields = do+  varName <- newName "m"+  let appliedFixtureT = AppT (ConT fixtureName) (VarT varName)++  let fieldNames = map (\(name, _, _) -> name) fixtureFields+  let fixtureClauses = map unimplementedField fieldNames++  let defImpl = RecConE fixtureName fixtureClauses+  let defDecl = FunD 'def [Clause [] (NormalB defImpl) []]++  return $ mkInstanceD [] (AppT (ConT ''Default) appliedFixtureT) [defDecl]++mkInstance :: Type -> Name -> Q Dec+mkInstance classType fixtureName = do+  eVar <- VarT <$> newName "e"+  mVar <- VarT <$> newName "m"++  let fixtureWithoutVarsT = AppT (ConT ''FixieT) (ConT fixtureName)+  let fixtureT = AppT (AppT fixtureWithoutVarsT eVar) mVar+  let instanceHead = AppT classType fixtureT++  classInfo <- reify (unappliedTypeName classType)+  methods <- case classInfo of+    ClassI (ClassD _ _ _ _ methods) _ -> return methods+    _ -> fail $ "mkInstance: expected a class type, given " ++ show classType+  funDecls <- traverse mkDictInstanceFunc methods++  return $ mkInstanceD [AppT (ConT ''Monad) mVar] instanceHead funDecls++{-|+  Ensures that a provided constraint is something test-fixture can actually+  derive an instance for. Specifically, it must be a constraint of kind+  * -> Constraint, and anything else is invalid.+-}+assertDerivableConstraint :: Type -> Q ()+assertDerivableConstraint classType = do+  info <- reify $ unappliedTypeName classType+  (ClassD _ _ classVars _ _) <- case info of+    ClassI dec _ -> return dec+    _ -> fail $ "mkFixture: expected a constraint, given ‘" ++ show (ppr classType) ++ "’"++  let classArgs = typeArgs classType+  let mkClassKind vars = foldr (\a b -> AppT (AppT ArrowT a) b) (ConT ''Constraint) (reverse varKinds)+        where varKinds = map (\(KindedTV _ k) -> k) vars+      constraintStr = show (ppr (ConT ''Constraint))++  when (length classArgs > length classVars) $+    fail $ "mkFixture: too many arguments for class\n"+        ++ "      in: " ++ show (ppr classType) ++ "\n"+        ++ "      for class of kind: " ++ show (ppr (mkClassKind classVars))++  when (length classArgs == length classVars) $+    fail $ "mkFixture: cannot derive instance for fully saturated constraint\n"+        ++ "      in: " ++ show (ppr classType) ++ "\n"+        ++ "      expected: * -> " ++ constraintStr ++ "\n"+        ++ "      given: " ++ constraintStr++  when (length classArgs < length classVars - 1) $+    fail $ "mkFixture: cannot derive instance for multi-parameter typeclass\n"+        ++ "      in: " ++ show (ppr classType) ++ "\n"+        ++ "      expected: * -> " ++ constraintStr ++ "\n"+        ++ "      given: " ++ show (ppr (mkClassKind $ drop (length classArgs) classVars))++{-|+  Given some 'Info' about a class, get its methods as 'SigD' declarations.+-}+classMethods :: MonadFail m => Info -> m [Dec]+classMethods (ClassI (ClassD _ _ _ _ methods) _) = return methods+classMethods other = fail $ "classMethods: expected a class name, given " ++ show other++{-|+  Helper for applying `methodToField` over multiple methods using the same name+  replacement for a particular typeclass.+-}+methodsToFields :: MonadFail m => Name -> Type -> [Dec] -> m [VarStrictType]+methodsToFields name typ = mapM (methodToField name typ)++{-|+  Converts a typeclass’s method (represented as a 'SigD') to a record field.+  There are two operations involved in this conversion:++    1. Prepend the name with the @_@ character to avoid name clashes. This is+       performed by 'methodNameToFieldName'.++    2. Replace the type variable bound by the typeclass constraint. To explain+       this step, consider the following typeclass:++       > class HasFoo x where+       >   foo :: x -> Foo++       The signature for the @foo@ class is actually as follows:++       > forall x. HasFoo x => x -> Foo++       However, when converted into a record, we want it to look like this:++       > data Record x = Record { fFoo :: x -> Foo }++       Specifically, we want to remove the @forall@ constraint, and we need+       to replace the type variable bound by the typeclass constraint with the+       type variable bound by the record declaration itself.++       To accomplish this, 'methodToField' accepts a 'Name' and a 'Type', where+       the 'Name' is the name of a replacement type variable, and the 'Type'+       is the typeclass whose constraint must be removed.+-}+methodToField :: MonadFail m => Name -> Type -> Dec -> m VarStrictType+methodToField mVar classT (SigD name typ) = (fieldName, noStrictness,) <$> newT+  where fieldName = methodNameToFieldName name+        newT = replaceClassConstraint classT mVar typ+methodToField _ _ _ = fail "methodToField: internal error; report a bug with the test-fixture package"++{-|+  Prepends a name with a @_@ or @~@ character (depending on whether or not the+  name refers to an infix operator) to avoid name clashes when generating record+  fields based on typeclass method names.+-}+methodNameToFieldName :: Name -> Name+methodNameToFieldName name = mkName (prefixChar : nameBase name)+  where isInfixChar c = (c `notElem` "_:\"'") && (isPunctuation c || isSymbol c)+        nameIsInfix = isInfixChar . head $ nameBase name+        prefixChar = if nameIsInfix then '~' else '_'++{-|+  Implements the class constraint replacement functionality as described in the+  documentation for 'methodToField'. Given a type that represents the typeclass+  whose constraint must be removed and a name used to replace the constrained+  type variable, it replaces the uses of that type variable everywhere in the+  quantified type and removes the constraint.+-}+replaceClassConstraint :: MonadFail m => Type -> Name -> Type -> m Type+replaceClassConstraint classType freeVar (ForallT vars preds typ) =+  let -- split the provided class into the typeclass and its arguments:+      --+      --             MonadFoo Int Bool+      --             ^^^^^^^^ ^^^^^^^^+      --                 |       |+      --  unappliedClassType   classTypeArgs+      unappliedClassType = unappliedType classType+      classTypeArgs = typeArgs classType++      -- find the constraint that belongs to the typeclass by searching for the+      -- constaint with the same base type+      ([replacedPred], newPreds) = partition ((unappliedClassType ==) . unappliedType) preds++      -- Get the type vars that we need to replace, and match them with their+      -- replacements. Since we have already validated that classType is the+      -- same as replacedPred but missing one argument (via+      -- assertDerivableConstraint), we can easily align the types we need to+      -- replace with their instantiations.+      replacedVars = typeVarNames replacedPred+      replacementTypes = classTypeArgs ++ [VarT freeVar]++      -- get the remaining vars in the forall quantification after stripping out+      -- the ones we’re replacing+      newVars = filter ((`notElem` replacedVars) . tyVarBndrName) vars++      -- actually perform the replacement substitution for each type var and its replacement+      replacedT = foldl' (flip $ uncurry substituteTypeVar) typ (zip replacedVars replacementTypes)+  in return $ ForallT newVars newPreds replacedT+replaceClassConstraint _ _ _ = fail "replaceClassConstraint: internal error; report a bug with the test-fixture package"++{-|+  Substitutes a type variable with a type within a particular type. This is used+  by 'replaceClassConstraint' to swap out the constrained and quantified type+  variable with the type variable bound within the record declaration.+-}+substituteTypeVar :: Name -> Type -> Type -> Type+substituteTypeVar initial replacement = doReplace+  where doReplace (ForallT a b t) = ForallT a b (doReplace t)+        doReplace (AppT a b) = AppT (doReplace a) (doReplace b)+        doReplace (SigT t k) = SigT (doReplace t) k+        doReplace t@(VarT n)+          | n == initial = replacement+          | otherwise    = t+        doReplace other = other++{-|+  Given a record field name, produces a 'FieldExp' that assigns that field to+  a function defined in terms of 'unimplemented', which will raise an error+  upon an attempt to invoke it that will contain a message that explains the+  method has not been implemented by a user.+-}+unimplementedField :: Name -> FieldExp+unimplementedField fieldName = (fieldName, unimplementedE)+  where unimplementedE = AppE (VarE 'unimplemented) (LitE (StringL $ nameBase fieldName))++{-|+  Generates an implementation of a method within a 'Fixie' typeclass+  instance for a generated fixture record. The implementation handles four+  things:++    1. It detects the arity of the method to implement and automatically creates+       a function declaration that accepts that many arguments.++    2. It retrieves the actual implementation out of the reader-provided+       typeclass dictionary using 'getFunction'.++    3. It captures the call of the function.++    4. It applies the reader-provided function to all of the arguments generated+       by the arity-detection pass from step 1.++   This function expects a signature declaration that describes the typeclass+   method to generate an implementation for, and it returns the function+   definition as a declaration.+-}+mkDictInstanceFunc :: Dec -> Q Dec+mkDictInstanceFunc (SigD name typ) = do+  let arity = functionTypeArity typ++  argNames <- replicateM arity (newName "x")+  let pats = map VarP argNames++  let askFunc = VarE (methodNameToFieldName name)+  let nameString = LitE (StringL (nameBase name))+  let vars = map VarE argNames++  implE <- [e|do+    fn <- getFunction $(return askFunc)+    let fnString = $(return nameString)+    let call = Call $ Function (pack fnString)+    captureCall call+    $(return $ applyE (VarE 'fn) vars)+   |]++  let funClause = Clause pats (NormalB implE) []+  return $ FunD name [funClause]+mkDictInstanceFunc other = fail $ "mkDictInstanceFunc: expected method signature, given " ++ show other++{-|+  Given a potentially applied type, like @T a b@, returns the base, unapplied+  type name, like @T@.+-}+unappliedType :: Type -> Type+unappliedType t@ConT{} = t+unappliedType (AppT t _) = unappliedType t+unappliedType other = error $ "expected plain applied type, given " ++ show other++{-|+  Like 'unappliedType', but extracts the 'Name' instead of 'Type'.+-}+unappliedTypeName :: Type -> Name+unappliedTypeName t = let (ConT name) = unappliedType t in name++{-|+  The inverse of 'unappliedType', this gets the arguments a type is applied to.+-}+typeArgs :: Type -> [Type]+typeArgs (AppT t a) = typeArgs t ++ [a]+typeArgs _          = []++{-|+  Given a type, returns a list of all of the unique type variables contained+  within it.+-}+typeVarNames :: Type -> [Name]+typeVarNames (VarT n) = [n]+typeVarNames (AppT a b) = nub (typeVarNames a ++ typeVarNames b)+typeVarNames _ = []++{-|+  Given any arbitrary 'TyVarBndr', gets its 'Name'.+-}+tyVarBndrName :: TyVarBndr -> Name+tyVarBndrName (PlainTV name) = name+tyVarBndrName (KindedTV name _) = name++{-|+  Given any arbitrary 'Type', gets its function arity as a 'Int'. Non-function+  types have arity @0@.++  >>> functionTypeArity [t|()|]+  0+  >>> functionTypeArity [t|() -> ()|]+  1+  >>> functionTypeArity [t|() -> () -> ()|]+  2+-}+functionTypeArity :: Type -> Int+functionTypeArity (AppT (AppT ArrowT _) b) = 1 + functionTypeArity b+functionTypeArity (ForallT _ _ typ) = functionTypeArity typ+functionTypeArity _ = 0++{-|+  Given an 'Exp' that represents a function value and a list of 'Exp's that+  represent function arguments, produces a new 'Exp' that applies the function+  to the provided arguments.+-}+applyE :: Exp -> [Exp] -> Exp+applyE = foldl' AppE++{------------------------------------------------------------------------------|+| The following definitions abstract over differences in base and              |+| template-haskell between GHC versions. This allows the same code to work     |+| without writing CPP everywhere and ending up with a small mess.              |+|------------------------------------------------------------------------------}++type MonadFail = Fail.MonadFail++mkInstanceD :: Cxt -> Type -> [Dec] -> Dec+mkInstanceD = InstanceD Nothing++mkDataD :: Cxt -> Name -> [TyVarBndr] -> [Con] -> Dec+mkDataD a b c d = DataD a b c Nothing d []++noStrictness :: Bang+noStrictness = Bang NoSourceUnpackedness NoSourceStrictness
+ src/Test/Fixie/TH/Internal/TypesQuasi.hs view
@@ -0,0 +1,115 @@+{-# OPTIONS_HADDOCK hide, not-home #-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}++module Test.Fixie.TH.Internal.TypesQuasi (ts) where++import Control.Monad ((<=<))+import Language.Haskell.Exts.Lexer+import Language.Haskell.Exts.Parser+import Language.Haskell.Exts.SrcLoc+import Language.Haskell.Meta.Syntax.Translate (toType)+import Language.Haskell.TH.Instances ()+import Language.Haskell.TH.Syntax hiding (Loc)+import Language.Haskell.TH.Quote++-- | A quasi-quoter like the built-in @[t| ... |]@ quasi-quoter, but produces+-- a /list/ of types instead of a single type. Each type should be separated by+-- a comma.+--+-- >>> [ts| Bool, (), String |]+-- [ConT GHC.Types.Bool,ConT GHC.Tuple.(),ConT GHC.Base.String]+-- >>> [ts| Maybe Int, Monad m |]+-- [AppT (ConT GHC.Base.Maybe) (ConT GHC.Types.Int),AppT (ConT GHC.Base.Monad) (VarT m)]+ts :: QuasiQuoter+ts = QuasiQuoter+  { quoteExp = \str -> case parseTypesSplitOnCommas str of+      ParseOk tys -> lift =<< mapM resolveTypeNames tys+      ParseFailed _ msg -> fail msg+  , quotePat = error "ts can only be used in an expression context"+  , quoteType = error "ts can only be used in an expression context"+  , quoteDec = error "ts can only be used in an expression context"+  }++parseTypesSplitOnCommas :: String -> ParseResult [Type]+parseTypesSplitOnCommas = fmap (map toType) . mapM parseType <=< lexSplitOnCommas++lexSplitOnCommas :: String -> ParseResult [String]+lexSplitOnCommas str = splitOnSrcSpans str <$> lexSplittingCommas str++splitOnSrcSpans :: String -> [SrcSpan] -> [String]+splitOnSrcSpans str [] = [str]+splitOnSrcSpans str spans@(x:xs) = case x of+  SrcSpan { srcSpanStartLine = line, srcSpanStartColumn = col }+    | line > 1 ->+      let (l, _:ls) = break (== '\n') str+          (r:rs) = splitOnSrcSpans ls (map advanceLine spans)+      in (l ++ "\n" ++ r) : rs+    | col > 1 ->+      let (currentLs, nextLs) = span ((== line) . srcSpanStartLine) spans+          (c:cs) = str+          (r:rs) = splitOnSrcSpans cs (map advanceColumn currentLs ++ nextLs)+      in (c : r) : rs+    | otherwise ->+      let (currentLs, nextLs) = span ((== line) . srcSpanStartLine) xs+          (_:cs) = str+      in "" : splitOnSrcSpans cs (map advanceColumn currentLs ++ nextLs)+++advanceLine :: SrcSpan -> SrcSpan+advanceLine s@SrcSpan { srcSpanStartLine = line } = s { srcSpanStartLine = line - 1 }++advanceColumn :: SrcSpan -> SrcSpan+advanceColumn s@SrcSpan { srcSpanStartColumn = col } = s { srcSpanStartColumn = col - 1 }++lexSplittingCommas :: String -> ParseResult [SrcSpan]+lexSplittingCommas = fmap splittingCommas . lexTokenStream++splittingCommas :: [Loc Token] -> [SrcSpan]+splittingCommas = map loc . go+  where go [] = []+        go (x@Loc{ unLoc = Comma }:xs) = x : go xs+        go (Loc{ unLoc = LeftParen }:xs) = go $ skipUntil RightParen xs+        go (Loc{ unLoc = LeftSquare }:xs) = go $ skipUntil RightSquare xs+        go (Loc{ unLoc = LeftCurly }:xs) = go $ skipUntil RightCurly xs+        go (_:xs) = go xs++        skipUntil _ [] = []+        skipUntil d (Loc{ unLoc = LeftParen }:xs) = skipUntil d $ skipUntil RightParen xs+        skipUntil d (Loc{ unLoc = LeftSquare }:xs) = skipUntil d $ skipUntil RightSquare xs+        skipUntil d (Loc{ unLoc = LeftCurly }:xs) = skipUntil d $ skipUntil RightCurly xs+        skipUntil d (Loc{ unLoc = t }:xs)+          | t == d    = xs+          | otherwise = skipUntil d xs++resolveTypeNames :: Type -> Q Type+resolveTypeNames (ConT nm) = ConT <$> resolveTypeName nm+resolveTypeNames (ForallT tyVars ctx t) = ForallT tyVars <$> mapM resolveTypeNames ctx <*> resolveTypeNames t+resolveTypeNames (AppT a b) = AppT <$> resolveTypeNames a <*> resolveTypeNames b+resolveTypeNames (SigT t k) = SigT <$> resolveTypeNames t <*> resolveTypeNames k+resolveTypeNames t@VarT{} = return t+resolveTypeNames t@PromotedT{} = return t+resolveTypeNames t@TupleT{} = return t+resolveTypeNames t@UnboxedTupleT{} = return t+resolveTypeNames t@ArrowT{} = return t+resolveTypeNames t@EqualityT = return t+resolveTypeNames t@ListT = return t+resolveTypeNames t@PromotedTupleT{} = return t+resolveTypeNames t@PromotedNilT = return t+resolveTypeNames t@PromotedConsT = return t+resolveTypeNames t@StarT = return t+resolveTypeNames t@ConstraintT = return t+resolveTypeNames t@LitT{} = return t+#if MIN_VERSION_template_haskell(2,11,0)+resolveTypeNames (InfixT a n b) = InfixT <$> resolveTypeNames a <*> resolveTypeName n <*> resolveTypeNames b+resolveTypeNames (UInfixT a n b) = UInfixT <$> resolveTypeNames a <*> resolveTypeName n <*> resolveTypeNames b+resolveTypeNames (ParensT t) = ParensT <$> resolveTypeNames t+resolveTypeNames t@WildCardT = return t+#endif++resolveTypeName :: Name -> Q Name+resolveTypeName (Name (OccName str) NameS) = lookupTypeName str >>= \case+  Just nm -> return nm+  Nothing -> fail $ "unbound type name ‘" ++ str ++ "’"+resolveTypeName nm = return nm
+ test/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Test/Test/Fixie/THSpec.hs view
@@ -0,0 +1,52 @@+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}++module Test.Test.Fixie.THSpec (spec) where++import Test.Hspec++import Control.Applicative ((<|>))+import Control.Monad (when)+import Control.Monad.Except (throwError)+import Control.Monad.Fail (MonadFail(..))+import Language.Haskell.TH.Syntax++import Test.Fixie+import Test.Fixie.TH+import Test.Fixie.TH.Internal (methodNameToFieldName)++class MultiParam a b where++mkFixture "Fixture" [ts| MonadFail, Quasi |]++spec :: Spec+spec = do+  describe "mkFixture" $+    it "raises an error for multi-parameter typeclasses" $ do+      let fixture = def+            { _qReport = \b s -> when b $ throwError s+            , _qNewName = \s -> return $ Name (OccName s) (NameU 0)+            , _qReify = \_ -> return $(lift =<< reify ''MultiParam)+            }+      let result = outputM fixture (runQ $ mkFixture "Fixture" [ts| MultiParam |])+      result `shouldBe` (Left $+           "mkFixture: cannot derive instance for multi-parameter typeclass\n"+        ++ "      in: Test.Test.Fixie.THSpec.MultiParam\n"+        ++ "      expected: * -> GHC.Types.Constraint\n"+        ++ "      given: * -> * -> GHC.Types.Constraint")++  describe "methodNameToFieldName" $ do+    it "prepends an underscore to ordinary names" $ do+      nameBase (methodNameToFieldName 'id) `shouldBe` "_id"+      nameBase (methodNameToFieldName '_fail) `shouldBe` "__fail"++    it "prepends a tilde to infix operators" $ do+      nameBase (methodNameToFieldName '(>>=)) `shouldBe` "~>>="+      nameBase (methodNameToFieldName '(<|>)) `shouldBe` "~<|>"
+ test/Test/Test/FixieSpec.hs view
@@ -0,0 +1,104 @@+{-# OPTIONS_GHC -fno-warn-unused-top-binds -fno-warn-redundant-constraints #-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}++module Test.Test.FixieSpec (spec) where++import Test.Hspec++import Control.Monad.Except (throwError, lift)+import Data.Void (Void)+import Test.Fixie+import Test.Fixie.TH+++newtype Id a = Id Int+newtype DBError = DBError () deriving (Eq, Show)++data HTTPRequest = GET String+data HTTPResponse = HTTPResponse { responseStatus :: Int }+data HTTPError++class DBRecord a where+  procureRecord :: a++data User = User deriving (Eq, Show)+instance DBRecord User where+  procureRecord = User++class Monad m => DB m where+  fetchRecord :: DBRecord a => Id a -> m (Either DBError a)+  insertRecord :: DBRecord a => a -> m (Either DBError (Id a))++class Monad m => HTTP m where+  sendRequest :: HTTPRequest -> m (Either HTTPError HTTPResponse)++class Monad m => Throw m where+  throwMessage :: String -> m a++useDBAndHTTP :: (DB m, HTTP m, DBRecord r) => r -> m (Either DBError r)+useDBAndHTTP record = do+  (Right (Id recordId)) <- insertRecord record+  (Right response) <- sendRequest $ GET ("/record/" ++ show recordId)+  fetchRecord $ Id (responseStatus response)++mkFixture "Fixture" [ts| DB, HTTP, Throw |]++fixtureValueM :: Fixture (FixieM Fixture Void)+fixtureValueM = def++fixtureOutputM :: Fixture (FixieM Fixture e)+fixtureOutputM = def++fixtureValueT :: Monad m => Fixture (FixieT Fixture Void m)+fixtureValueT = def++fixtureOutputT :: Monad m => Fixture (FixieT Fixture e m)+fixtureOutputT = def++-- ensure generation of empty fixtures works+mkFixture "EmptyFixture" []++-- ensure fixtures can be generated for partially applied multi-parameter typeclasses+class MultiParam e m | m -> e where+  firstParam :: m e++mkFixture "MultiParamFixture" [ts| MultiParam Bool |]++spec :: Spec+spec = do+  describe "mkFixture" $ do+    it "generates a fixture type that can be used to stub out methods" $ do+      let fixture = def+            { _fetchRecord = \_ -> return $ Right procureRecord+            , _insertRecord = \_ -> return $ Right (Id 42)+            , _sendRequest = \_ -> return $ Right (HTTPResponse 200)+            }+      valueM fixture (useDBAndHTTP User) `shouldBe` Right User++    it "can handle partially applied multi parameter typeclasses" $ do+      let fixture = def { _firstParam = return True }+      valueM fixture firstParam `shouldBe` True++  describe "handle throws" $ do+    it "capture a thrown error message" $ do+      let message = "error message"+      let throw = throwMessage message >> return ()+      let fixture = def+            { _throwMessage = \msg -> do+                lift (msg `shouldBe` message)+                note "test test"+                note "abc"+                throwError msg+            }+      actual <- outputFunctionsNotesT fixture throw+      let expected = (Left "error message", ["throwMessage", "throwError"], ["test test", "abc"])+      actual `shouldBe` expected