product-profunctors 0.5 → 0.6
raw patch · 5 files changed
+135/−30 lines, 5 filesdep +product-profunctorsdep ~basedep ~contravariantdep ~profunctors
Dependencies added: product-profunctors
Dependency ranges changed: base, contravariant, profunctors
Files
- Data/Profunctor/Product/TH.hs +48/−28
- Test/CheckTypes.hs +47/−0
- Test/Definitions.hs +22/−0
- Test/Main.hs +4/−0
- product-profunctors.cabal +14/−2
Data/Profunctor/Product/TH.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | If you have a data declaration which is a polymorphic product, -- for example --@@ -13,12 +15,10 @@ -- -- then you can use Template Haskell to automatically derive the -- product-profunctor 'Default' instances and product-profunctor--- \"adaptor\" with the following imports and splice:+-- \"adaptor\" with the following import and splice: -- -- @--- import Data.Profunctor.Product (ProductProfunctor, p\<n\>)--- import Data.Profunctor (dimap)--- import Data.Profunctor.Product.Default (Default, def)+-- import Data.Profunctor.Product (p\<n\>) -- -- $(makeAdaptorAndInstance \"pFoo\" ''Foo) -- @@@ -28,10 +28,9 @@ -- * The adaptor for a type Foo is by convention called pFoo, but in -- practice you can call it anything. ----- Notice that currently the Template Haskell requires you import a--- number of other names from other modules. This is because it is--- badly written and this restriction will go away in a future--- release.+-- Notice that currently the Template Haskell requires you import p<n>+-- manually. This is because it is badly written and this restriction+-- will go away in a future release. -- -- The instance generated will be --@@ -49,6 +48,11 @@ module Data.Profunctor.Product.TH where +import Data.Profunctor (dimap)+import Data.Profunctor.Product (ProductProfunctor, p1, p2, p3, p4, p5, p6, p7,+ p8, p9, p10, p11, p12, p13, p14, p15, p16, p17,+ p18)+import Data.Profunctor.Product.Default (Default, def) import Language.Haskell.TH (Dec(DataD, SigD, FunD, InstanceD), mkName, TyVarBndr(PlainTV, KindedTV), Con(RecC, NormalC),@@ -164,31 +168,30 @@ instanceDefinition tyName' numTyVars numConVars adaptorName' conName=instanceDec where instanceDec = InstanceD instanceCxt instanceType [defDefinition] instanceCxt = map (uncurry ClassP) (pClass:defClasses)- pClass = (mkName "ProductProfunctor", [varTS "p"])+ pClass = (''ProductProfunctor, [varTS "p"]) defaultPredOfVar :: String -> (Name, [Type])- defaultPredOfVar fn = (mkName "Default", [varTS "p",- mkTySuffix "0" fn,- mkTySuffix "1" fn])+ defaultPredOfVar fn = (''Default, [varTS "p",+ mkTySuffix "0" fn,+ mkTySuffix "1" fn]) defClasses = map defaultPredOfVar (allTyVars numTyVars) pArg :: String -> Type pArg s = pArg' tyName' s numTyVars - instanceType = appTAll (conTS "Default")+ instanceType = appTAll (ConT ''Default) [varTS "p", pArg "0", pArg "1"] - defDefinition = FunD (mkName "def") [Clause [] defBody []]+ defDefinition = FunD 'def [Clause [] defBody []] defBody = NormalB(VarE adaptorName' `AppE` appEAll (ConE conName) defsN)- defsN = replicate numConVars (varS "def")+ defsN = replicate numConVars (VarE 'def) adaptorSig :: Name -> Int -> Name -> Dec adaptorSig tyName' numTyVars = flip SigD adaptorType where adaptorType = ForallT scope adaptorCxt adaptorAfterCxt adaptorAfterCxt = before `appArrow` after- adaptorCxt = [ClassP (mkName "ProductProfunctor")- [VarT (mkName "p")]]+ adaptorCxt = [ClassP ''ProductProfunctor [VarT (mkName "p")]] before = appTAll (ConT tyName') pArgs pType = VarT (mkName "p") pArgs = map pApp tyVars@@ -207,6 +210,32 @@ , map (mkTyVarsuffix "0") tyVars , map (mkTyVarsuffix "1") tyVars ] +-- This should probably fail in a more graceful way than an error. I+-- guess via Either or Q.+tupleAdaptors :: Int -> Name+tupleAdaptors n = case n of 1 -> 'p1+ 2 -> 'p2+ 3 -> 'p3+ 4 -> 'p4+ 5 -> 'p5+ 6 -> 'p6+ 7 -> 'p7+ 8 -> 'p8+ 9 -> 'p9+ 10 -> 'p10+ 11 -> 'p11+ 12 -> 'p12+ 13 -> 'p13+ 14 -> 'p14+ 15 -> 'p15+ 16 -> 'p16+ 17 -> 'p17+ 18 -> 'p18+ _ -> error errorMsg+ where errorMsg = "Data.Profunctor.Product.TH: "+ ++ show n+ ++ " is too many type variables for me!"+ adaptorDefinition :: Int -> Name -> Name -> Dec adaptorDefinition numConVars conName = flip FunD [clause] where clause = Clause [] body wheres@@ -214,8 +243,8 @@ fromTupleN = mkName "fromTuple" toTupleE = VarE toTupleN fromTupleE = VarE fromTupleN- theDimap = appEAll (varS "dimap") [toTupleE, fromTupleE]- pN = VarE (mkName ("p" ++ show numConVars))+ theDimap = appEAll (VarE 'dimap) [toTupleE, fromTupleE]+ pN = VarE (tupleAdaptors numConVars) body = NormalB (theDimap `o` pN `o` toTupleE) wheres = [toTuple conName (toTupleN, numConVars), fromTuple conName (fromTupleN, numConVars)]@@ -265,12 +294,6 @@ varS :: String -> Exp varS = VarE . mkName -conES :: String -> Exp-conES = ConE . mkName--conPS :: String -> [Pat] -> Pat-conPS = ConP . mkName- varPS :: String -> Pat varPS = VarP . mkName @@ -285,9 +308,6 @@ varTS :: String -> Type varTS = VarT . mkName--conTS :: String -> Type-conTS = ConT . mkName appTAll :: Type -> [Type] -> Type appTAll = foldl AppT
+ Test/CheckTypes.hs view
@@ -0,0 +1,47 @@+module CheckTypes where++import Data.Profunctor.Product (ProductProfunctor)+import Data.Profunctor.Product.Default (Default, def)++import Definitions (Data2, Data3, Record2, Record3,+ pData2, pData3, pRecord2, pRecord3)++-- The test suite checks that the TH derived adaptor is of the correct+-- type and that the typeclass instance has been generated. We don't+-- actually check the implementation since by parametricity I expect+-- that only the order in which the product profunctors are combined+-- can vary.++pData2' :: ProductProfunctor p =>+ Data2 (p a a') (p b b') -> p (Data2 a b) (Data2 a' b')+pData2' = pData2++pData3' :: ProductProfunctor p =>+ Data3 (p a a') (p b b') (p c c') -> p (Data3 a b c) (Data3 a' b' c')+pData3' = pData3++pRecord2' :: ProductProfunctor p =>+ Record2 (p a a') (p b b') -> p (Record2 a b) (Record2 a' b')+pRecord2' = pRecord2++pRecord3' :: ProductProfunctor p =>+ Record3 (p a a') (p b b') (p c c') -> p (Record3 a b c) (Record3 a' b' c')+pRecord3' = pRecord3++instanceData2 :: (ProductProfunctor p, Default p a a', Default p b b')+ => p (Data2 a b) (Data2 a' b')+instanceData2 = def++instanceData3 :: (ProductProfunctor p,+ Default p a a', Default p b b', Default p c c')+ => p (Data3 a b c) (Data3 a' b' c')+instanceData3 = def++instanceRecord2 :: (ProductProfunctor p, Default p a a', Default p b b')+ => p (Record2 a b) (Record2 a' b')+instanceRecord2 = def++instanceRecord3 :: (ProductProfunctor p,+ Default p a a', Default p b b', Default p c c')+ => p (Record3 a b c) (Record3 a' b' c')+instanceRecord3 = def
+ Test/Definitions.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Definitions where++-- We define the data types and generate the TH in a separate module+-- because we want to ensure that no external names are required to be+-- imported.++import Data.Profunctor.Product.TH (makeAdaptorAndInstance)++data Data2 a b = Data2 a b+data Data3 a b c = Data3 a b c++data Record2 a b = Record2 { a2 :: a, b2 :: b }+data Record3 a b c = Record3 { a3 :: a, b3 :: b, c3 :: c }++$(makeAdaptorAndInstance "pData2" ''Data2)+$(makeAdaptorAndInstance "pData3" ''Data3)+$(makeAdaptorAndInstance "pRecord2" ''Record2)+$(makeAdaptorAndInstance "pRecord3" ''Record3)
+ Test/Main.hs view
@@ -0,0 +1,4 @@+import CheckTypes++main :: IO ()+main = return ()
product-profunctors.cabal view
@@ -1,5 +1,5 @@ name: product-profunctors-version: 0.5+version: 0.6 synopsis: product-profunctors description: Product profunctors homepage: https://github.com/tomjaguarpaw/product-profunctors@@ -9,7 +9,7 @@ maintainer: Purely Agile category: Control, Category build-type: Simple-cabal-version: >= 1.6+cabal-version: >= 1.8 source-repository head Type: git@@ -26,3 +26,15 @@ Data.Profunctor.Product.TH, Data.Profunctor.Product.Tuples ghc-options: -Wall++test-suite test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules: CheckTypes,+ Definitions+ hs-source-dirs: Test+ build-depends:+ base >= 4 && < 5,+ profunctors,+ product-profunctors+ ghc-options: -Wall