th-lego 0.1.0.4 → 0.2

raw patch · 5 files changed

+440/−57 lines, 5 filesdep +QuickCheckdep +quickcheck-instancesdep +rerebasedep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, quickcheck-instances, rerebase, tasty, tasty-hunit, tasty-quickcheck, th-lego

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

• library/THLego/Helpers.hs +23/−5
• library/THLego/Instances.hs +166/−38
• library/THLego/Lambdas.hs +87/−13
• test/Main.hs +147/−0
• th-lego.cabal +17/−1

@@ -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 =

@@ -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

@@ -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 =

@@ -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)+      ]+    ]

@@ -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