diff --git a/library/THLego/Helpers.hs b/library/THLego/Helpers.hs --- a/library/THLego/Helpers.hs +++ b/library/THLego/Helpers.hs @@ -106,13 +106,31 @@ [a] -> a a -> appliedTupleE a -indexName :: Int -> Name -indexName = +decimalIndexName :: Int -> Name +decimalIndexName = mkName . showChar '_' . show -enumNames :: Int -> [Name] -enumNames = - fmap indexName . enumFromTo 0 . pred +alphabeticIndexName :: Int -> Name +alphabeticIndexName a = + mkName string + where + string = + showIntAtBase 26 (chr . (+) 97) a "" + +enumAlphabeticNames :: Int -> [Name] +enumAlphabeticNames = + fmap alphabeticIndexName . enumFromTo 0 . pred + +{-| +Map every element of a list with a new name. +-} +{-# INLINE mapWithAlphabeticName #-} +mapWithAlphabeticName :: (Name -> a -> b) -> [a] -> [b] +mapWithAlphabeticName f list = + foldr step (const []) list 0 + where + step a next !index = + f (alphabeticIndexName index) a : next (succ index) aName :: Name aName = diff --git a/library/THLego/Instances.hs b/library/THLego/Instances.hs --- a/library/THLego/Instances.hs +++ b/library/THLego/Instances.hs @@ -7,11 +7,15 @@ import qualified TemplateHaskell.Compat.V0208 as Compat import qualified Data.Text as Text import qualified THLego.Lambdas as Lambdas +import qualified THLego.Helpers as Helpers -- * IsLabel ------------------------- +{-| +The most general template for 'IsLabel'. +-} isLabel :: TyLit -> Type -> Exp -> Dec isLabel label repType fromLabelExp = InstanceD Nothing [] headType [fromLabelDec] @@ -27,76 +31,197 @@ -- ** Constructor ------------------------- +{-| + +> instance (a ~ Text) => IsLabel "error" (a -> Result) +-} +constructorIsLabel :: TyLit -> Type -> [Type] -> Exp -> Dec +constructorIsLabel label ownerType memberTypes fromLabelExp = + InstanceD Nothing paramPreds headType [fromLabelDec] + where + paramPreds = + memberTypes + & Helpers.mapWithAlphabeticName (\ n t -> multiAppT EqualityT [VarT n, t]) + headType = + multiAppT (ConT ''IsLabel) [LitT label, repType] + where + repType = + arrowChainT memberVarTypes ownerType + where + memberVarTypes = + Helpers.mapWithAlphabeticName (const . VarT) paramPreds + fromLabelDec = + FunD 'fromLabel [Clause [] (NormalB fromLabelExp) []] + newtypeConstructorIsLabel :: TyLit -> Type -> Name -> Type -> Dec newtypeConstructorIsLabel label ownerType conName memberType = - isLabel label repType fromLabelExp - where - repType = - arrowChainT [memberType] ownerType - fromLabelExp = - ConE conName + sumConstructorIsLabel label ownerType conName [memberType] sumConstructorIsLabel :: TyLit -> Type -> Name -> [Type] -> Dec sumConstructorIsLabel label ownerType conName memberTypes = - isLabel label repType fromLabelExp - where - repType = - arrowChainT memberTypes ownerType - fromLabelExp = - ConE conName + constructorIsLabel label ownerType memberTypes (ConE conName) enumConstructorIsLabel :: TyLit -> Type -> Name -> Dec enumConstructorIsLabel label ownerType conName = - isLabel label ownerType fromLabelExp - where - fromLabelExp = - ConE conName + sumConstructorIsLabel label ownerType conName [] {-| 'IsLabel' instance which converts tuple to ADT. -} tupleAdtConstructorIsLabel :: TyLit -> Type -> Name -> [Type] -> Dec tupleAdtConstructorIsLabel label ownerType conName memberTypes = - isLabel label repType fromLabelExp + constructorIsLabel label ownerType [memberType] fromLabelExp where - repType = - arrowChainT [appliedTupleT memberTypes] ownerType + memberType = + appliedTupleOrSingletonT memberTypes fromLabelExp = Lambdas.tupleToProduct conName (length memberTypes) +-- ** Mapper +------------------------- + +{-| +Template of 'IsLabel' for instances mapping to mapper functions. + +> instance (mapper ~ (Text -> Text)) => IsLabel "name" (mapper -> Person -> Person) + +-} +mapperIsLabel :: + {-| Field label. -} + TyLit -> + {-| Type of the product. -} + Type -> + {-| Type of the mapper function. -} + Type -> + {-| 'fromLabel' definition expression. -} + Exp -> + {-| 'IsLabel' instance declaration. -} + Dec +mapperIsLabel label ownerType projectionType fromLabelExp = + InstanceD Nothing [memberPred] headType [fromLabelDec] + where + projVarType = + VarT (mkName "mapper") + memberPred = + multiAppT EqualityT [projVarType, projectionType] + headType = + multiAppT (ConT ''IsLabel) [LitT label, instanceType] + where + instanceType = + arrowChainT [projVarType, ownerType] ownerType + fromLabelDec = + FunD 'fromLabel [Clause [] (NormalB fromLabelExp) []] + +{-| +Template of 'IsLabel' for instances mapping to mapper functions. + +> instance (mapper ~ (Text -> Text)) => IsLabel "name" (mapper -> Person -> Person) +-} +productMapperIsLabel :: + {-| Field label. -} + TyLit -> + {-| Type of the product. -} + Type -> + {-| Type of the member we\'re focusing on. -} + Type -> + {-| Constructor name. -} + Name -> + {-| Total amount of members in the product. -} + Int -> + {-| Offset of the member we're focusing on. -} + Int -> + {-| 'IsLabel' instance declaration. -} + Dec +productMapperIsLabel label ownerType memberType conName totalMemberTypes offset = + mapperIsLabel label ownerType + (multiAppT ArrowT [memberType, memberType]) + (Lambdas.productMapper conName totalMemberTypes offset) + +{-| +Template of 'IsLabel' for instances mapping to mapper functions. + +> instance (mapper ~ (Int -> Text -> (Int, Text))) => IsLabel "error" (mapper -> Result -> Result) +-} +sumMapperIsLabel :: + {-| Field label. -} + TyLit -> + {-| Type of the product. -} + Type -> + {-| Constructor name. -} + Name -> + {-| Member types we\'re focusing on. -} + [Type] -> + {-| 'IsLabel' instance declaration. -} + Dec +sumMapperIsLabel label ownerType conName memberTypes = + mapperIsLabel label ownerType + (arrowChainT memberTypes (appliedTupleOrSingletonT memberTypes)) + (Lambdas.sumMapper conName (length memberTypes)) + -- ** Accessor ------------------------- -productAccessorIsLabel :: TyLit -> Type -> Type -> Name -> Int -> Int -> Dec +{-| +Template of 'IsLabel' for instances mapping to accessor functions. +-} +accessorIsLabel :: TyLit -> Type -> Type -> Exp -> Dec +accessorIsLabel label ownerType projectionType fromLabelExp = + InstanceD Nothing [memberPred] headType [fromLabelDec] + where + projVarType = + VarT aName + memberPred = + multiAppT EqualityT [projVarType, projectionType] + headType = + multiAppT (ConT ''IsLabel) [LitT label, instanceType] + where + instanceType = + multiAppT ArrowT [ownerType, projVarType] + fromLabelDec = + FunD 'fromLabel [Clause [] (NormalB fromLabelExp) []] + +{-| +Instance of 'IsLabel' for a member of a product type. +-} +productAccessorIsLabel :: + {-| Field label. -} + TyLit -> + {-| Type of the product. -} + Type -> + {-| Type of the member we\'re focusing on. -} + Type -> + {-| Constructor name. -} + Name -> + {-| Total amount of members in the product. -} + Int -> + {-| Offset of the member we're focusing on. -} + Int -> + {-| 'IsLabel' instance declaration. -} + Dec productAccessorIsLabel label ownerType projectionType conName numMembers offset = - isLabel label repType fromLabelExp + accessorIsLabel label ownerType projectionType fromLabelExp where - repType = - multiAppT ArrowT [ownerType, projectionType] fromLabelExp = Lambdas.productGetter conName numMembers offset +{-| +> instance (a ~ Maybe Text) => IsLabel "error" (Result -> a) +-} sumAccessorIsLabel :: TyLit -> Type -> Name -> [Type] -> Dec sumAccessorIsLabel label ownerType conName memberTypes = - isLabel label repType fromLabelExp + accessorIsLabel label ownerType projectionType fromLabelExp where - repType = - multiAppT ArrowT [ownerType, projectionType] - where - projectionType = - AppT (ConT ''Maybe) (appliedTupleT memberTypes) + projectionType = + AppT (ConT ''Maybe) (appliedTupleOrSingletonT memberTypes) fromLabelExp = Lambdas.adtConstructorNarrower conName (length memberTypes) enumAccessorIsLabel :: TyLit -> Type -> Name -> Dec enumAccessorIsLabel label ownerType conName = - isLabel label repType fromLabelExp + accessorIsLabel label ownerType projectionType fromLabelExp where - repType = - multiAppT ArrowT [ownerType, projectionType] - where - projectionType = - ConT ''Bool + projectionType = + ConT ''Bool fromLabelExp = Lambdas.enumConstructorToBool conName @@ -129,6 +254,7 @@ Type -> {-| Name of the constructor. -} Name -> + {-| 'HasField' instance declaration. -} Dec enumHasField fieldLabel ownerType constructorName = hasField fieldLabel ownerType projectionType getFieldFunClauses @@ -170,6 +296,7 @@ Name -> {-| Member types of that constructor. -} [Type] -> + {-| 'HasField' instance declaration. -} Dec sumHasField fieldLabel ownerType constructorName memberTypes = hasField fieldLabel ownerType projectionType getFieldFunClauses @@ -180,8 +307,8 @@ [matching, unmatching] where varNames = - enumFromTo 1 (length memberTypes) & - fmap (mkName . showChar '_' . show) + memberTypes & + mapWithAlphabeticName (const . id) matching = Clause [ConP constructorName pats] (NormalB bodyExp) [] where @@ -203,7 +330,7 @@ TyLit -> {-| Type of the product. -} Type -> - {-| Type of the member we're focusing on. -} + {-| Type of the member we\'re focusing on. -} Type -> {-| Constructor name. -} Name -> @@ -211,6 +338,7 @@ Int -> {-| Offset of the member we're focusing on. -} Int -> + {-| 'HasField' instance declaration. -} Dec productHasField fieldLabel ownerType projectionType constructorName totalMemberTypes offset = hasField fieldLabel ownerType projectionType getFieldFunClauses diff --git a/library/THLego/Lambdas.hs b/library/THLego/Lambdas.hs --- a/library/THLego/Lambdas.hs +++ b/library/THLego/Lambdas.hs @@ -34,7 +34,7 @@ LamE [pat] exp where varName = - indexName index + alphabeticIndexName index pat = ConP conName pats where @@ -64,23 +64,97 @@ productSetter conName numMembers index = LamE [stateP, valP] exp where - valName = - mkName "x" + memberName = + alphabeticIndexName index + memberNames = + fmap alphabeticIndexName (enumFromTo 0 (pred numMembers)) stateP = ConP conName pats where pats = - fmap (VarP . indexName) (enumFromTo 0 (pred numMembers)) + fmap VarP memberNames valP = - VarP valName + VarP memberName exp = - foldl' AppE (ConE conName) (fmap VarE names) + foldl' AppE (ConE conName) (fmap VarE memberNames) + +{-| +Lambda expression, which maps a product member by index. +-} +productMapper :: + {-| Constructor name. -} + Name -> + {-| Total amount of members. -} + Int -> + {-| Index of the member. -} + Int -> + {-| + Lambda expression of the following form: + + > (member -> member) -> product -> product + -} + Exp +productMapper conName numMembers index = + LamE [mapperP, stateP] exp + where + memberName = + alphabeticIndexName index + memberNames = + fmap alphabeticIndexName (enumFromTo 0 (pred numMembers)) + valName = + alphabeticIndexName index + fnName = + mkName "fn" + mapperP = + VarP fnName + stateP = + ConP conName pats where - names = - fmap indexName (enumFromTo 0 (pred index)) <> - pure valName <> - fmap indexName (enumFromTo (succ index) (pred numMembers)) + pats = + fmap VarP memberNames + exp = + foldl' AppE (ConE conName) $ + fmap (VarE . alphabeticIndexName) (enumFromTo 0 (pred index)) <> + pure (AppE (VarE fnName) (VarE valName)) <> + fmap (VarE . alphabeticIndexName) (enumFromTo (succ index) (pred numMembers)) +{-| +Lambda expression, which maps a sum member by index. +-} +sumMapper :: + {-| Constructor name. -} + Name -> + {-| Total amount of members. -} + Int -> + {-| + Lambda expression of the following form: + + > (membersTuple -> membersTuple) -> sum -> sum + -} + Exp +sumMapper conName numMembers = + LamE [mapperP] (matcher matches) + where + fnName = + mkName "fn" + mapperP = + VarP fnName + matches = + [pos, neg] + where + pos = + Match (ConP conName memberPats) (NormalB bodyExp) [] + where + memberVarNames = + fmap alphabeticIndexName (enumFromTo 0 (pred numMembers)) + memberPats = + fmap VarP memberVarNames + bodyExp = + AppE (tupleToProduct conName numMembers) + (multiAppE (VarE fnName) (fmap VarE memberVarNames)) + neg = + Match (VarP aName) (NormalB (VarE aName)) [] + adtConstructorNarrower :: Name -> Int -> Exp adtConstructorNarrower conName numMembers = matcher [positive, negative] @@ -89,7 +163,7 @@ Match (ConP conName (fmap VarP varNames)) (NormalB exp) [] where varNames = - fmap indexName (enumFromTo 0 (pred numMembers)) + fmap alphabeticIndexName (enumFromTo 0 (pred numMembers)) exp = AppE (ConE 'Just) (Compat.tupE (fmap VarE varNames)) negative = @@ -115,7 +189,7 @@ LamE [pat] exp where varNames = - fmap indexName (enumFromTo 0 (pred numMembers)) + fmap alphabeticIndexName (enumFromTo 0 (pred numMembers)) pat = ConP conName (fmap VarP varNames) exp = @@ -126,7 +200,7 @@ LamE [pat] exp where varNames = - fmap indexName (enumFromTo 0 (pred numMembers)) + fmap alphabeticIndexName (enumFromTo 0 (pred numMembers)) pat = TupP (fmap VarP varNames) exp = diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,147 @@ +module Main where + +import Prelude hiding (assert) +import Test.QuickCheck.Instances +import Test.Tasty +import Test.Tasty.Runners +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Language.Haskell.TH.Syntax +import qualified Test.QuickCheck as QuickCheck +import qualified THLego.Instances as Instances +import qualified THLego.Helpers as Helpers + + +main = + defaultMain $ + testGroup "Instances" [ + testCase "productMapperIsLabel" $ let + dec = + Instances.productMapperIsLabel + (StrTyLit "start") + (ConT ''CharPos) + (ConT ''Loc) + 'Loc + 5 + 3 + in + case dec of + InstanceD _ cxt headType _ -> + do + assertEqual "" + [AppT + (AppT EqualityT (VarT (mkName "mapper"))) + (AppT (AppT ArrowT (ConT ''Loc)) + (ConT ''Loc))] + cxt + assertEqual "" + (AppT + (AppT (ConT ''IsLabel) (LitT (StrTyLit "start"))) + (AppT (AppT ArrowT (VarT (mkName "mapper"))) + (AppT + (AppT ArrowT (ConT ''CharPos)) + (ConT ''CharPos)))) + headType + _ -> + assertFailure (show dec) + , + testGroup "sumMapperIsLabel" [ + testCase "No fields" $ let + dec = + Instances.sumMapperIsLabel + (StrTyLit "arrow") + (ConT ''Type) + 'ArrowT + [] + in + case dec of + InstanceD _ decCxt decHeadType _ -> + let + mapperType = + TupleT 0 + predType = + EqualityT + `AppT` VarT (mkName "mapper") + `AppT` mapperType + fnType = + ConT ''Type + & AppT (AppT ArrowT (ConT ''Type)) + & AppT (AppT ArrowT (VarT (mkName "mapper"))) + headType = + ConT ''IsLabel + `AppT` LitT (StrTyLit "arrow") + `AppT` fnType + in do + assertEqual "cxt" [predType] decCxt + assertEqual "headType" headType decHeadType + _ -> + assertFailure (show dec) + , + testCase "1 field" $ let + dec = + Instances.sumMapperIsLabel + (StrTyLit "var") + (ConT ''Type) + 'VarT + [ConT ''Name] + in + case dec of + InstanceD _ decCxt decHeadType _ -> + let + mapperType = + ConT ''Name + & AppT (AppT ArrowT (ConT ''Name)) + predType = + EqualityT `AppT` VarT (mkName "mapper") `AppT` mapperType + fnType = + ConT ''Type + & AppT (AppT ArrowT (ConT ''Type)) + & AppT (AppT ArrowT (VarT (mkName "mapper"))) + headType = + ConT ''IsLabel + `AppT` LitT (StrTyLit "var") + `AppT` fnType + in do + assertEqual "cxt" [predType] decCxt + assertEqual "headType" headType decHeadType + _ -> + assertFailure (show dec) + , + testCase "Multiple fields" $ let + dec = + Instances.sumMapperIsLabel + (StrTyLit "val") + (ConT ''Dec) + 'ValD + [ConT ''Pat, ConT ''Body, AppT ListT (ConT ''Dec)] + in + case dec of + InstanceD _ decCxt decHeadType _ -> + let + tupleType = + TupleT 3 + `AppT` (ConT ''Pat) + `AppT` (ConT ''Body) + `AppT` (AppT ListT (ConT ''Dec)) + mapperType = + AppT (AppT ArrowT (ConT ''Pat)) + (AppT (AppT ArrowT (ConT ''Body)) + (AppT (AppT ArrowT (AppT ListT (ConT ''Dec))) + tupleType)) + predType = + EqualityT `AppT` VarT (mkName "mapper") `AppT` mapperType + fnType = + ConT ''Dec + & AppT (AppT ArrowT (ConT ''Dec)) + & AppT (AppT ArrowT (VarT (mkName "mapper"))) + headType = + ConT ''IsLabel + `AppT` LitT (StrTyLit "val") + `AppT` fnType + in do + assertEqual "cxt" [predType] decCxt + assertEqual "headType" headType decHeadType + _ -> + assertFailure (show dec) + ] + ] diff --git a/th-lego.cabal b/th-lego.cabal --- a/th-lego.cabal +++ b/th-lego.cabal @@ -1,5 +1,5 @@ name: th-lego -version: 0.1.0.4 +version: 0.2 synopsis: Template Haskell construction utilities description: A collection of templates for the typical patterns appearing @@ -37,3 +37,19 @@ template-haskell >=2.8 && <3, template-haskell-compat-v0208 >=0.1.5 && <0.2, text >=1 && <2 + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: test + default-extensions: BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples + default-language: Haskell2010 + main-is: Main.hs + build-depends: + QuickCheck >=2.8.1 && <3, + quickcheck-instances >=0.3.11 && <0.4, + rerebase >=1.10.0.1 && <2, + tasty >=0.12 && <2, + tasty-hunit >=0.9 && <0.11, + tasty-quickcheck >=0.9 && <0.11, + template-haskell, + th-lego