diff --git a/Data/Profunctor/Product.hs b/Data/Profunctor/Product.hs --- a/Data/Profunctor/Product.hs +++ b/Data/Profunctor/Product.hs @@ -61,6 +61,7 @@ empty :: p () () (***!) :: p a b -> p a' b' -> p (a, a') (b, b') +-- This appears to be just 'Data.Functor.Contravariant.Divisible' class Contravariant f => ProductContravariant f where point :: f () (***<) :: f a -> f b -> f (a, b) diff --git a/Data/Profunctor/Product/Default.hs b/Data/Profunctor/Product/Default.hs --- a/Data/Profunctor/Product/Default.hs +++ b/Data/Profunctor/Product/Default.hs @@ -102,6 +102,18 @@ Default p a3 b3, Default p a4 b4, Default p a5 b5, Default p a6 b6, Default p a7 b7, Default p a8 b8, Default p a9 b9, Default p a10 b10, Default p a11 b11, + Default p a12 b12, Default p a13 b13) + => Default p (a1, a2, a3, a4, a5, a6, a7, a8, + a9, a10, a11, a12, a13) + (b1, b2, b3, b4, b5, b6, b7, b8, + b9, b10, b11, b12, b13) where + def = p13 (def, def, def, def, def, def, def, def, def, def, + def, def, def) + +instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2, + Default p a3 b3, Default p a4 b4, Default p a5 b5, + Default p a6 b6, Default p a7 b7, Default p a8 b8, + Default p a9 b9, Default p a10 b10, Default p a11 b11, Default p a12 b12, Default p a13 b13, Default p a14 b14) => Default p (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) @@ -134,3 +146,30 @@ b9, b10, b11, b12, b13, b14, b15, b16) where def = p16 (def, def, def, def, def, def, def, def, def, def, def, def, def, def, def, def) + +instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2, + Default p a3 b3, Default p a4 b4, Default p a5 b5, + Default p a6 b6, Default p a7 b7, Default p a8 b8, + Default p a9 b9, Default p a10 b10, Default p a11 b11, + Default p a12 b12, Default p a13 b13, Default p a14 b14, + Default p a15 b15, Default p a16 b16, Default p a17 b17) + => Default p (a1, a2, a3, a4, a5, a6, a7, a8, + a9, a10, a11, a12, a13, a14, a15, a16, a17) + (b1, b2, b3, b4, b5, b6, b7, b8, + b9, b10, b11, b12, b13, b14, b15, b16, b17) where + def = p17 (def, def, def, def, def, def, def, def, def, def, + def, def, def, def, def, def, def) + +instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2, + Default p a3 b3, Default p a4 b4, Default p a5 b5, + Default p a6 b6, Default p a7 b7, Default p a8 b8, + Default p a9 b9, Default p a10 b10, Default p a11 b11, + Default p a12 b12, Default p a13 b13, Default p a14 b14, + Default p a15 b15, Default p a16 b16, Default p a17 b17, + Default p a18 b18) + => Default p (a1, a2, a3, a4, a5, a6, a7, a8, + a9, a10, a11, a12, a13, a14, a15, a16, a17, a18) + (b1, b2, b3, b4, b5, b6, b7, b8, + b9, b10, b11, b12, b13, b14, b15, b16, b17, b18) where + def = p18 (def, def, def, def, def, def, def, def, def, def, + def, def, def, def, def, def, def, def) diff --git a/Data/Profunctor/Product/TH.hs b/Data/Profunctor/Product/TH.hs --- a/Data/Profunctor/Product/TH.hs +++ b/Data/Profunctor/Product/TH.hs @@ -18,20 +18,12 @@ -- \"adaptor\" with the following import and splice: -- -- @ --- import Data.Profunctor.Product (p\) --- -- $(makeAdaptorAndInstance \"pFoo\" ''Foo) -- @ -- --- * \ is the number of fields in your record, so for Foo \ would be 3. --- -- * 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 p --- manually. This is because it is badly written and this restriction --- will go away in a future release. --- -- The instance generated will be -- -- @ @@ -58,22 +50,24 @@ Con(RecC, NormalC), Strict(NotStrict), Clause(Clause), Type(VarT, ForallT, AppT, ArrowT, ConT), - Body(NormalB), Q, Pred(ClassP), + Body(NormalB), Q, classP, Exp(ConE, VarE, InfixE, AppE, TupE), Pat(TupP, VarP, ConP), Name, Info(TyConI), reify) import Control.Monad ((<=<)) +import Control.Applicative ((<$>), (<*>)) +import Control.Arrow (second) makeAdaptorAndInstance :: String -> Name -> Q [Dec] makeAdaptorAndInstance adaptorNameS = returnOrFail <=< r makeAandIE <=< reify where r = (return .) - returnOrFail (Right decs) = return decs + returnOrFail (Right decs) = decs returnOrFail (Left errMsg) = fail errMsg makeAandIE = makeAdaptorAndInstanceE adaptorNameS type Error = String -makeAdaptorAndInstanceE :: String -> Info -> Either Error [Dec] +makeAdaptorAndInstanceE :: String -> Info -> Either Error (Q [Dec]) makeAdaptorAndInstanceE adaptorNameS info = do (tyName, tyVars, conName, conTys) <- dataDecStuffOfInfo info let numTyVars = length tyVars @@ -84,7 +78,7 @@ instanceDefinition' = instanceDefinition tyName numTyVars numConTys adaptorNameN conName - return [adaptorSig', adaptorDefinition', instanceDefinition'] + return ((\a b -> [a, adaptorDefinition', b]) <$> adaptorSig' <*> instanceDefinition') -- TODO: support newtypes? dataDecStuffOfInfo :: Info -> Either Error (Name, [Name], Name, [Name]) @@ -137,9 +131,11 @@ datatype' = datatype tyName' tyVars conName derivings makeRecord :: MakeRecordT -> Q [Dec] -makeRecord r = return decs +makeRecord r = decs where MakeRecordT tyName conName tyVars derivings _ = r - decs = [datatype', adaptorSig', adaptorDefinition', instanceDefinition'] + decs = (\a i -> [datatype', a, adaptorDefinition', i]) + <$> adaptorSig' + <*> instanceDefinition' tyName' = mkName tyName conName' = mkName conName @@ -164,18 +160,20 @@ toField s = (mkName s, NotStrict, VarT (mkName s)) derivings' = map mkName derivings -instanceDefinition :: Name -> Int -> Int -> Name -> Name -> Dec +instanceDefinition :: Name -> Int -> Int -> Name -> Name -> Q Dec instanceDefinition tyName' numTyVars numConVars adaptorName' conName=instanceDec - where instanceDec = InstanceD instanceCxt instanceType [defDefinition] - instanceCxt = map (uncurry ClassP) (pClass:defClasses) - pClass = (''ProductProfunctor, [varTS "p"]) + where instanceDec = fmap (\i -> InstanceD i instanceType [defDefinition]) + instanceCxt + instanceCxt = mapM (uncurry classP) (pClass:defClasses) + pClass = (''ProductProfunctor, [return (varTS "p")]) defaultPredOfVar :: String -> (Name, [Type]) defaultPredOfVar fn = (''Default, [varTS "p", mkTySuffix "0" fn, mkTySuffix "1" fn]) - defClasses = map defaultPredOfVar (allTyVars numTyVars) + defClasses = map (second (map return) . defaultPredOfVar) + (allTyVars numTyVars) pArg :: String -> Type pArg s = pArg' tyName' s numTyVars @@ -187,11 +185,11 @@ defBody = NormalB(VarE adaptorName' `AppE` appEAll (ConE conName) defsN) defsN = replicate numConVars (VarE 'def) -adaptorSig :: Name -> Int -> Name -> Dec -adaptorSig tyName' numTyVars = flip SigD adaptorType - where adaptorType = ForallT scope adaptorCxt adaptorAfterCxt +adaptorSig :: Name -> Int -> Name -> Q Dec +adaptorSig tyName' numTyVars n = fmap (SigD n) adaptorType + where adaptorType = fmap (\a -> ForallT scope a adaptorAfterCxt) adaptorCxt adaptorAfterCxt = before `appArrow` after - adaptorCxt = [ClassP ''ProductProfunctor [VarT (mkName "p")]] + adaptorCxt = fmap (:[]) (classP ''ProductProfunctor [return (VarT (mkName "p"))]) before = appTAll (ConT tyName') pArgs pType = VarT (mkName "p") pArgs = map pApp tyVars diff --git a/product-profunctors.cabal b/product-profunctors.cabal --- a/product-profunctors.cabal +++ b/product-profunctors.cabal @@ -1,5 +1,5 @@ name: product-profunctors -version: 0.6 +version: 0.6.1 synopsis: product-profunctors description: Product profunctors homepage: https://github.com/tomjaguarpaw/product-profunctors @@ -17,8 +17,8 @@ library build-depends: base >= 4 && < 5 - , profunctors >= 4.0 && < 4.3 - , contravariant >= 0.4 && < 1.3 + , profunctors >= 4.0 && < 4.5 + , contravariant >= 0.4 && < 1.4 , template-haskell exposed-modules: Data.Profunctor.Product, Data.Profunctor.Product.Default,