diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 --- a/CHANGELOG.md +++ /dev/null @@ -1,9 +0,0 @@ -# 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)). diff --git a/fixie.cabal b/fixie.cabal --- a/fixie.cabal +++ b/fixie.cabal @@ -1,7 +1,7 @@ name: fixie version: - 0.0.0 + 1.0.0 synopsis: Opininated testing framework for mtl style (spies, stubs, and mocks) description: @@ -23,7 +23,6 @@ build-type: Simple extra-source-files: - CHANGELOG.md LICENSE README.md cabal-version: @@ -36,9 +35,8 @@ exposed-modules: Test.Fixie Test.Fixie.Internal - Test.Fixie.TH - Test.Fixie.TH.Internal - Test.Fixie.TH.Internal.TypesQuasi + Test.Fixie.Internal.TH + Test.Fixie.Internal.TH.TypesQuasi build-depends: base >= 4.7 && < 5 , containers diff --git a/src/Test/Fixie.hs b/src/Test/Fixie.hs --- a/src/Test/Fixie.hs +++ b/src/Test/Fixie.hs @@ -1,5 +1,11 @@ module Test.Fixie ( module Test.Fixie.Internal + , mkFixture + , def + , ts ) where import Test.Fixie.Internal hiding (Call(..), captureCall, getFixture, getFunction) +import Test.Fixie.Internal.TH (mkFixture) +import Test.Fixie.Internal.TH.TypesQuasi (ts) +import Data.Default.Class (def) diff --git a/src/Test/Fixie/Internal/TH.hs b/src/Test/Fixie/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/src/Test/Fixie/Internal/TH.hs @@ -0,0 +1,375 @@ +{-# OPTIONS_HADDOCK hide, not-home #-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module Test.Fixie.Internal.TH where + +import qualified Control.Monad.Fail as Fail + +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 diff --git a/src/Test/Fixie/Internal/TH/TypesQuasi.hs b/src/Test/Fixie/Internal/TH/TypesQuasi.hs new file mode 100644 --- /dev/null +++ b/src/Test/Fixie/Internal/TH/TypesQuasi.hs @@ -0,0 +1,115 @@ +{-# OPTIONS_HADDOCK hide, not-home #-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +module Test.Fixie.Internal.TH.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 diff --git a/src/Test/Fixie/TH.hs b/src/Test/Fixie/TH.hs deleted file mode 100644 --- a/src/Test/Fixie/TH.hs +++ /dev/null @@ -1,9 +0,0 @@ -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) diff --git a/src/Test/Fixie/TH/Internal.hs b/src/Test/Fixie/TH/Internal.hs deleted file mode 100644 --- a/src/Test/Fixie/TH/Internal.hs +++ /dev/null @@ -1,376 +0,0 @@ -{-# 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 diff --git a/src/Test/Fixie/TH/Internal/TypesQuasi.hs b/src/Test/Fixie/TH/Internal/TypesQuasi.hs deleted file mode 100644 --- a/src/Test/Fixie/TH/Internal/TypesQuasi.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# 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 diff --git a/test/Test/Test/Fixie/THSpec.hs b/test/Test/Test/Fixie/THSpec.hs --- a/test/Test/Test/Fixie/THSpec.hs +++ b/test/Test/Test/Fixie/THSpec.hs @@ -19,8 +19,7 @@ import Language.Haskell.TH.Syntax import Test.Fixie -import Test.Fixie.TH -import Test.Fixie.TH.Internal (methodNameToFieldName) +import Test.Fixie.Internal.TH (methodNameToFieldName) class MultiParam a b where diff --git a/test/Test/Test/FixieSpec.hs b/test/Test/Test/FixieSpec.hs --- a/test/Test/Test/FixieSpec.hs +++ b/test/Test/Test/FixieSpec.hs @@ -17,7 +17,6 @@ import Control.Monad.Except (throwError, lift) import Data.Void (Void) import Test.Fixie -import Test.Fixie.TH newtype Id a = Id Int