diff --git a/Data/Profunctor/Product.hs b/Data/Profunctor/Product.hs --- a/Data/Profunctor/Product.hs +++ b/Data/Profunctor/Product.hs @@ -1,4 +1,5 @@ -module Data.Profunctor.Product where +module Data.Profunctor.Product (module Data.Profunctor.Product.Newtype, + module Data.Profunctor.Product) where import Prelude hiding (id) import Data.Profunctor (Profunctor, dimap, lmap, WrappedArrow) @@ -12,6 +13,7 @@ import Control.Arrow (Arrow, (***), (<<<), arr, (&&&)) import Control.Applicative (Applicative, liftA2, pure) import Data.Monoid (Monoid, mempty, (<>)) +import Data.Profunctor.Product.Newtype -- ProductProfunctor and ProductContravariant are potentially -- redundant type classes. It seems to me that these are equivalent @@ -58,6 +60,10 @@ -- Still, at least we now have default implementations of the class -- methods, which makes things simpler. +-- | A 'ProductProfunctor' is a generalization of an 'Applicative'. +-- It has an "input", contravariant type parameter on the left as well +-- as the usual 'Applicative' "output", covariant parameter on teh +-- right. class Profunctor p => ProductProfunctor p where empty :: p () () (***!) :: p a b -> p a' b' -> p (a, a') (b, b') @@ -66,6 +72,17 @@ class Contravariant f => ProductContravariant f where point :: f () (***<) :: f a -> f b -> f (a, b) + +-- | This is exactly the same as @Applicative@'s @\<*\>@, but for a +-- 'ProductProfunctor'. +(****) :: ProductProfunctor p => p a (b -> c) -> p a b -> p a c +(****) f x = Profunctor.dimap dup (uncurry ($)) (f ***! x) + where dup y = (y, y) + +-- | This is exactly 'Profunctor.rmap', given a name which highlights +-- the similarity to @Applicative@'s @\<$\>@. +(***$) :: ProductProfunctor p => (b -> c) -> p a b -> p a c +(***$) = Profunctor.rmap defaultEmpty :: Applicative (p ()) => p () () defaultEmpty = pure () diff --git a/Data/Profunctor/Product/Internal/TH.hs b/Data/Profunctor/Product/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/Data/Profunctor/Product/Internal/TH.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Data.Profunctor.Product.Internal.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, p19, p20, p21, p22, p23, p24) +import Data.Profunctor.Product.Default (Default, def) +import qualified Data.Profunctor.Product.Newtype as N +import Language.Haskell.TH (Dec(DataD, SigD, FunD, InstanceD, NewtypeD), + mkName, newName, nameBase, TyVarBndr(PlainTV, KindedTV), + Con(RecC, NormalC), + Clause(Clause), + Type(VarT, ForallT, AppT, ArrowT, ConT), + Body(NormalB), Q, classP, + Exp(ConE, VarE, InfixE, AppE, TupE, LamE), + Pat(TupP, VarP, ConP), Name, + Info(TyConI), reify) +import Control.Monad ((<=<)) +import Control.Applicative (pure) +import Control.Arrow (second) + +makeAdaptorAndInstanceI :: Maybe String -> Name -> Q [Dec] +makeAdaptorAndInstanceI adaptorNameM = returnOrFail <=< r makeAandIE <=< reify + where r = (return .) + returnOrFail (Right decs) = decs + returnOrFail (Left errMsg) = fail errMsg + makeAandIE = makeAdaptorAndInstanceE adaptorNameM + +type Error = String + +makeAdaptorAndInstanceE :: Maybe String -> Info -> Either Error (Q [Dec]) +makeAdaptorAndInstanceE adaptorNameM info = do + (tyName, tyVars, conName, conTys) <- dataDecStuffOfInfo info + let numTyVars = length tyVars + numConTys = length conTys + defaultAdaptorName = (mkName . ("p" ++) . nameBase) conName + adaptorNameN = maybe defaultAdaptorName mkName adaptorNameM + adaptorSig' = adaptorSig tyName numTyVars adaptorNameN + adaptorDefinition' = adaptorDefinition numTyVars conName adaptorNameN + instanceDefinition' = instanceDefinition tyName numTyVars numConTys + adaptorNameN conName + + newtypeInstance' = if length conTys == 1 then + newtypeInstance conName tyName + else + return [] + + return $ do + as <- sequence [adaptorSig', pure adaptorDefinition', instanceDefinition'] + ns <- newtypeInstance' + return (as ++ ns) + +newtypeInstance :: Name -> Name -> Q [Dec] +newtypeInstance conName tyName = do + x <- newName "x" + + let body = [ FunD 'N.constructor [simpleClause (NormalB (ConE conName))] + , FunD 'N.field [simpleClause (NormalB (LamE [ConP conName [VarP x]] (VarE x)))] ] + + return [InstanceD [] (ConT ''N.Newtype `AppT` ConT tyName) body] + +dataDecStuffOfInfo :: Info -> Either Error (Name, [Name], Name, [Name]) +dataDecStuffOfInfo (TyConI (DataD _cxt tyName tyVars constructors _deriving)) = + do + (conName, conTys) <- extractConstructorStuff constructors + let tyVars' = map varNameOfBinder tyVars + return (tyName, tyVars', conName, conTys) +dataDecStuffOfInfo (TyConI (NewtypeD _cxt tyName tyVars constructor _deriving)) = + do + (conName, conTys) <- extractConstructorStuff [constructor] + let tyVars' = map varNameOfBinder tyVars + return (tyName, tyVars', conName, conTys) +dataDecStuffOfInfo _ = Left "That doesn't look like a data or newtype declaration to me" + +varNameOfType :: Type -> Either Error Name +varNameOfType (VarT n) = Right n +varNameOfType x = Left $ "Found a non-variable type" ++ show x + +varNameOfBinder :: TyVarBndr -> Name +varNameOfBinder (PlainTV n) = n +varNameOfBinder (KindedTV n _) = n + +conStuffOfConstructor :: Con -> Either Error (Name, [Name]) +conStuffOfConstructor (NormalC conName st) = do + conTys <- mapM (varNameOfType . snd) st + return (conName, conTys) +conStuffOfConstructor (RecC conName vst) = do + conTys <- mapM (varNameOfType . thrd) vst + return (conName, conTys) + where thrd = \(_,_,x) -> x +conStuffOfConstructor _ = Left "I can't deal with your constructor type" + +constructorOfConstructors :: [Con] -> Either Error Con +constructorOfConstructors [single] = return single +constructorOfConstructors [] = Left "I need at least one constructor" +constructorOfConstructors _many = + Left "I can't deal with more than one constructor" + +extractConstructorStuff :: [Con] -> Either Error (Name, [Name]) +extractConstructorStuff = conStuffOfConstructor <=< constructorOfConstructors + +instanceDefinition :: Name -> Int -> Int -> Name -> Name -> Q Dec +instanceDefinition tyName' numTyVars numConVars adaptorName' conName=instanceDec + where instanceDec = fmap (\i -> InstanceD i instanceType [defDefinition]) + instanceCxt + instanceCxt = mapM (uncurry classP) (pClass:defClasses) + pClass :: Monad m => (Name, [m Type]) + pClass = (''ProductProfunctor, [return (varTS "p")]) + + defaultPredOfVar :: String -> (Name, [Type]) + defaultPredOfVar fn = (''Default, [varTS "p", + mkTySuffix "0" fn, + mkTySuffix "1" fn]) + + defClasses = map (second (map return) . defaultPredOfVar) + (allTyVars numTyVars) + + pArg :: String -> Type + pArg s = pArg' tyName' s numTyVars + + instanceType = appTAll (ConT ''Default) + [varTS "p", pArg "0", pArg "1"] + + defDefinition = FunD 'def [simpleClause defBody] + defBody = NormalB(VarE adaptorName' `AppE` appEAll (ConE conName) defsN) + defsN = replicate numConVars (VarE 'def) + +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 = fmap (:[]) (classP ''ProductProfunctor [return (VarT (mkName "p"))]) + before = appTAll (ConT tyName') pArgs + pType = VarT (mkName "p") + pArgs = map pApp tyVars + pApp :: String -> Type + pApp v = appTAll pType [mkVarTsuffix "0" v, mkVarTsuffix "1" v] + + + tyVars = allTyVars numTyVars + + pArg :: String -> Type + pArg s = pArg' tyName' s numTyVars + + after = appTAll pType [pArg "0", pArg "1"] + + scope = concat [ [PlainTV (mkName "p")] + , 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 + 19 -> 'p19 + 20 -> 'p20 + 21 -> 'p21 + 22 -> 'p22 + 23 -> 'p23 + 24 -> 'p24 + _ -> 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 + toTupleN = mkName "toTuple" + fromTupleN = mkName "fromTuple" + toTupleE = VarE toTupleN + fromTupleE = VarE fromTupleN + 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)] + +xTuple :: ([Pat] -> Pat) -> ([Exp] -> Exp) -> (Name, Int) -> Dec +xTuple patCon retCon (funN, numTyVars) = FunD funN [clause] + where clause = Clause [pat] body [] + pat = patCon varPats + body = NormalB (retCon varExps) + varPats = map varPS (allTyVars numTyVars) + varExps = map varS (allTyVars numTyVars) + +fromTuple :: Name -> (Name, Int) -> Dec +fromTuple conName = xTuple patCon retCon + where patCon = TupP + retCon = appEAll (ConE conName) + +toTuple :: Name -> (Name, Int) -> Dec +toTuple conName = xTuple patCon retCon + where patCon = ConP conName + retCon = TupE + +{- +Note that we can also do the instance definition like this, but it would +require pulling the to/fromTuples to the top level + +instance (ProductProfunctor p, Default p a a', Default p b b', + Default p c c', Default p d d', Default p e e', + Default p f f', Default p g g', Default p h h') + => Default p (LedgerRow' a b c d e f g h) + (LedgerRow' a' b' c' d' e' f' g' h') where + def = dimap tupleOfLedgerRow lRowOfTuple def +-} + +pArg' :: Name -> String -> Int -> Type +pArg' tn s = appTAll (ConT tn) . map (varTS . (++s)) . allTyVars + +allTyVars :: Int -> [String] +allTyVars numTyVars = map varA tyNums + where varA i = "a" ++ show i ++ "_" + tyNums :: [Int] + tyNums = [1..numTyVars] + +o :: Exp -> Exp -> Exp +o x y = InfixE (Just x) (varS ".") (Just y) + +varS :: String -> Exp +varS = VarE . mkName + +varPS :: String -> Pat +varPS = VarP . mkName + +mkTyVarsuffix :: String -> String -> TyVarBndr +mkTyVarsuffix s = PlainTV . mkName . (++s) + +mkTySuffix :: String -> String -> Type +mkTySuffix s = varTS . (++s) + +mkVarTsuffix :: String -> String -> Type +mkVarTsuffix s = VarT . mkName . (++s) + +varTS :: String -> Type +varTS = VarT . mkName + +appTAll :: Type -> [Type] -> Type +appTAll = foldl AppT + +appEAll :: Exp -> [Exp] -> Exp +appEAll = foldl AppE + +appArrow :: Type -> Type -> Type +appArrow l r = appTAll ArrowT [l, r] + +simpleClause :: Body -> Clause +simpleClause x = Clause [] x [] diff --git a/Data/Profunctor/Product/Newtype.hs b/Data/Profunctor/Product/Newtype.hs new file mode 100644 --- /dev/null +++ b/Data/Profunctor/Product/Newtype.hs @@ -0,0 +1,10 @@ +module Data.Profunctor.Product.Newtype where + +import qualified Data.Profunctor as P + +class Newtype t where + constructor :: a -> t a + field :: t a -> a + +pNewtype :: (P.Profunctor p, Newtype t) => p a b -> p (t a) (t b) +pNewtype = P.dimap field constructor 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 @@ -15,314 +15,133 @@ -- -- then you can use Template Haskell to automatically derive the -- product-profunctor 'Default' instances and product-profunctor --- \"adaptor\" with the following import and splice: +-- \"adaptor\" with the following splice: -- -- @ -- $(makeAdaptorAndInstance \"pFoo\" ''Foo) -- @ -- --- * The adaptor for a type Foo is by convention called pFoo, but in --- practice you can call it anything. +-- The adaptor for a type @Foo@ is by convention called @pFoo@, but in +-- practice you can call it anything. If you don't care to specify +-- the name @pFoo@ yourself you can use -- --- The instance generated will be +-- @ +-- $(makeAdaptorAndInstance' ''Foo) +-- @ -- +-- and it will be named @pFoo@ automatically. +-- +-- @pFoo@ will have the type +-- -- @ +-- pFoo :: ProductProfunctor p => +-- Foo (p a a') (p b b') (p c c') -> p (Foo a b c) (Foo a' b' c') +-- @ +-- +-- and the instance generated will be +-- +-- @ -- instance (ProductProfunctor p, Default p a a', Default p b b', Default p c c') -- => Default p (Foo a b c) (Foo a' b' c') -- @ -- --- and pFoo will have the type +-- If you are confused about the meaning of @pFoo@ it may help to +-- consider the corresponding function that works with @Applicative@s +-- (its implementation is given below). -- -- @ +-- pFooApplicative :: Applicative f => +-- Foo (f a) (f b) (f c) -> f (Foo a b c) +-- @ +-- +-- The product-profunctor \"adaptor\" (in this case @pFoo@) is a +-- generalization of @Data.Traversable.sequence@ in two different +-- ways. Firstly it works on datatypes with multiple type parameters. +-- Secondly it works on 'ProductProfunctor's, which are themselves a +-- generalization of 'Applicative's. +-- +-- If your type has only one field, for example +-- +-- @ +-- data Foo a = Foo a +-- @ +-- +-- or +-- +-- @ +-- newtype Foo a = Foo a +-- @ +-- +-- then you will also get the instance +-- +-- @ +-- instance 'N.Newtype' Foo where +-- 'N.constructor' = Foo +-- 'N.field' = \(Foo x) -> x +-- @ +-- +-- which allows you to use the polymorphic function 'N.pNewtype' +-- instead of @pFoo@. +-- +-- If you prefer not to use Template Haskell then the generated code +-- can be written by hand because it is quite simple. It corresponds +-- very closely to what you would do in the more familiar +-- @Applicative@ case. For an @Applicative@ we would write +-- +-- @ +-- pFooApplicative :: Applicative f => +-- Foo (f a) (f b) (f c) -> f (Foo a b c) +-- pFooApplicative f = Foo \<$\> foo f +-- \<*\> bar f +-- \<*\> baz f +-- @ +-- +-- whereas for a @ProductProfunctor@ we write +-- +-- @ +-- import Data.Profunctor (lmap) +-- import Data.Profunctor.Product ((***$), (****)) +-- -- pFoo :: ProductProfunctor p => -- Foo (p a a') (p b b') (p c c') -> p (Foo a b c) (Foo a' b' c') +-- pFoo f = Foo ***$ lmap foo (foo f) +-- **** lmap bar (bar f) +-- **** lmap baz (baz f) -- @ - -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, p19, p20, p21, p22, p23, p24) -import Data.Profunctor.Product.Default (Default, def) -import Language.Haskell.TH (Dec(DataD, SigD, FunD, InstanceD, NewtypeD), - mkName, TyVarBndr(PlainTV, KindedTV), - Con(RecC, NormalC), - Strict(NotStrict), Clause(Clause), - Type(VarT, ForallT, AppT, ArrowT, ConT), - 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) = decs - returnOrFail (Left errMsg) = fail errMsg - makeAandIE = makeAdaptorAndInstanceE adaptorNameS - -type Error = String - -makeAdaptorAndInstanceE :: String -> Info -> Either Error (Q [Dec]) -makeAdaptorAndInstanceE adaptorNameS info = do - (tyName, tyVars, conName, conTys) <- dataDecStuffOfInfo info - let numTyVars = length tyVars - numConTys = length conTys - adaptorNameN = mkName adaptorNameS - adaptorSig' = adaptorSig tyName numTyVars adaptorNameN - adaptorDefinition' = adaptorDefinition numTyVars conName adaptorNameN - instanceDefinition' = instanceDefinition tyName numTyVars numConTys - adaptorNameN conName - - return ((\a b -> [a, adaptorDefinition', b]) <$> adaptorSig' <*> instanceDefinition') - --- TODO: support newtypes? -dataDecStuffOfInfo :: Info -> Either Error (Name, [Name], Name, [Name]) -dataDecStuffOfInfo (TyConI (DataD _cxt tyName tyVars constructors _deriving)) = - do - (conName, conTys) <- extractConstructorStuff constructors - let tyVars' = map varNameOfBinder tyVars - return (tyName, tyVars', conName, conTys) -dataDecStuffOfInfo (TyConI (NewtypeD _cxt tyName tyVars constructor _deriving)) = - do - (conName, conTys) <- extractConstructorStuff [constructor] - let tyVars' = map varNameOfBinder tyVars - return (tyName, tyVars', conName, conTys) -dataDecStuffOfInfo _ = Left "That doesn't look like a data or newtpe declaration to me" - -varNameOfType :: Type -> Either Error Name -varNameOfType (VarT n) = Right n -varNameOfType x = Left $ "Found a non-variable type" ++ show x - -varNameOfBinder :: TyVarBndr -> Name -varNameOfBinder (PlainTV n) = n -varNameOfBinder (KindedTV n _) = n - -conStuffOfConstructor :: Con -> Either Error (Name, [Name]) -conStuffOfConstructor (NormalC conName st) = do - conTys <- mapM (varNameOfType . snd) st - return (conName, conTys) -conStuffOfConstructor (RecC conName vst) = do - conTys <- mapM (varNameOfType . thrd) vst - return (conName, conTys) - where thrd = \(_,_,x) -> x -conStuffOfConstructor _ = Left "I can't deal with your constructor type" - -constructorOfConstructors :: [Con] -> Either Error Con -constructorOfConstructors [single] = return single -constructorOfConstructors [] = Left "I need at least one constructor" -constructorOfConstructors _many = Left msg - where msg = "I can't deal with more than one constructor" - -extractConstructorStuff :: [Con] -> Either Error (Name, [Name]) -extractConstructorStuff = conStuffOfConstructor <=< constructorOfConstructors - --- MakeRecordT and makeRecordData were from an old interface. We could probably --- delete them now. -data MakeRecordT = MakeRecordT { typeName :: String - , constructorName :: String - , fieldNames :: [String] - , deriving_ :: [String] - , adaptorName :: String } - -makeRecordData :: MakeRecordT -> Q [Dec] -makeRecordData r = return [datatype'] where - MakeRecordT tyName conName tyVars derivings _ = r - tyName' = mkName tyName - datatype' = datatype tyName' tyVars conName derivings - -makeRecord :: MakeRecordT -> Q [Dec] -makeRecord r = decs - where MakeRecordT tyName conName tyVars derivings _ = r - decs = (\a i -> [datatype', a, adaptorDefinition', i]) - <$> adaptorSig' - <*> instanceDefinition' - tyName' = mkName tyName - conName' = mkName conName - - adaptorName' = mkName (adaptorName r) - - numTyVars = length tyVars - - datatype' = datatype tyName' tyVars conName derivings - adaptorSig' = adaptorSig tyName' numTyVars adaptorName' - adaptorDefinition' = adaptorDefinition numTyVars conName' adaptorName' - instanceDefinition' = instanceDefinition tyName' numTyVars numTyVars - adaptorName' conName' - --- The implementations of the datatype (only used in the old makeRecord), --- instance and adaptor follow. -datatype :: Name -> [String] -> String -> [String] -> Dec -datatype tyName tyVars conName derivings = datatype' - where datatype' = DataD [] tyName tyVars' [con] derivings' - fields = map toField tyVars - tyVars' = map (PlainTV . mkName) tyVars - con = RecC (mkName conName) fields - toField s = (mkName s, NotStrict, VarT (mkName s)) - derivings' = map mkName derivings - -instanceDefinition :: Name -> Int -> Int -> Name -> Name -> Q Dec -instanceDefinition tyName' numTyVars numConVars adaptorName' conName=instanceDec - 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 (second (map return) . defaultPredOfVar) - (allTyVars numTyVars) - - pArg :: String -> Type - pArg s = pArg' tyName' s numTyVars - - instanceType = appTAll (ConT ''Default) - [varTS "p", pArg "0", pArg "1"] - - defDefinition = FunD 'def [Clause [] defBody []] - defBody = NormalB(VarE adaptorName' `AppE` appEAll (ConE conName) defsN) - defsN = replicate numConVars (VarE 'def) - -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 = fmap (:[]) (classP ''ProductProfunctor [return (VarT (mkName "p"))]) - before = appTAll (ConT tyName') pArgs - pType = VarT (mkName "p") - pArgs = map pApp tyVars - pApp :: String -> Type - pApp v = appTAll pType [mkVarTsuffix "0" v, mkVarTsuffix "1" v] +-- +-- The 'Default' instance is then very simple. +-- +-- @ +-- instance (ProductProfunctor p, Default p a a', Default p b b', Default p c c') +-- => Default p (Foo a b c) (Foo a' b' c') where +-- def = pFoo (Foo def def def) +-- @ - tyVars = allTyVars numTyVars - - pArg :: String -> Type - pArg s = pArg' tyName' s numTyVars - - after = appTAll pType [pArg "0", pArg "1"] - - scope = concat [ [PlainTV (mkName "p")] - , 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 - 19 -> 'p19 - 20 -> 'p20 - 21 -> 'p21 - 22 -> 'p22 - 23 -> 'p23 - 24 -> 'p24 - _ -> 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 - toTupleN = mkName "toTuple" - fromTupleN = mkName "fromTuple" - toTupleE = VarE toTupleN - fromTupleE = VarE fromTupleN - 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)] - -xTuple :: ([Pat] -> Pat) -> ([Exp] -> Exp) -> (Name, Int) -> Dec -xTuple patCon retCon (funN, numTyVars) = FunD funN [clause] - where clause = Clause [pat] body [] - pat = patCon varPats - body = NormalB (retCon varExps) - varPats = map varPS (allTyVars numTyVars) - varExps = map varS (allTyVars numTyVars) - -fromTuple :: Name -> (Name, Int) -> Dec -fromTuple conName = xTuple patCon retCon - where patCon = TupP - retCon = appEAll (ConE conName) - -toTuple :: Name -> (Name, Int) -> Dec -toTuple conName = xTuple patCon retCon - where patCon = ConP conName - retCon = TupE - -{- -Note that we can also do the instance definition like this, but it would -require pulling the to/fromTuples to the top level - -instance (ProductProfunctor p, Default p a a', Default p b b', - Default p c c', Default p d d', Default p e e', - Default p f f', Default p g g', Default p h h') - => Default p (LedgerRow' a b c d e f g h) - (LedgerRow' a' b' c' d' e' f' g' h') where - def = dimap tupleOfLedgerRow lRowOfTuple def --} - -pArg' :: Name -> String -> Int -> Type -pArg' tn s = appTAll (ConT tn) . map (varTS . (++s)) . allTyVars - -allTyVars :: Int -> [String] -allTyVars numTyVars = map varA tyNums - where varA i = "a" ++ show i ++ "_" - tyNums :: [Int] - tyNums = [1..numTyVars] - -o :: Exp -> Exp -> Exp -o x y = InfixE (Just x) (varS ".") (Just y) - -varS :: String -> Exp -varS = VarE . mkName - -varPS :: String -> Pat -varPS = VarP . mkName - -mkTyVarsuffix :: String -> String -> TyVarBndr -mkTyVarsuffix s = PlainTV . mkName . (++s) - -mkTySuffix :: String -> String -> Type -mkTySuffix s = varTS . (++s) - -mkVarTsuffix :: String -> String -> Type -mkVarTsuffix s = VarT . mkName . (++s) +module Data.Profunctor.Product.TH where -varTS :: String -> Type -varTS = VarT . mkName +import Data.Profunctor.Product.Internal.TH (makeAdaptorAndInstanceI) +import qualified Language.Haskell.TH as TH -appTAll :: Type -> [Type] -> Type -appTAll = foldl AppT +-- | For example +-- +-- @ +-- $(makeAdaptorAndInstance \"pFoo\" ''Foo) +-- @ +-- +-- generates the 'Default' instance and the adaptor @pFoo@. +makeAdaptorAndInstance :: String -> TH.Name -> TH.Q [TH.Dec] +makeAdaptorAndInstance adaptorNameS = makeAdaptorAndInstanceI (Just adaptorNameS) -appEAll :: Exp -> [Exp] -> Exp -appEAll = foldl AppE +-- | For example +-- +-- @ +-- $(makeAdaptorAndInstance ''Foo) +-- @ +-- +-- generates the 'Default' instance and the adaptor @pFoo@. The name +-- of the adaptor is chosen by prefixing the type name \"Foo\" with +-- the string \"p\". +makeAdaptorAndInstance' :: TH.Name -> TH.Q [TH.Dec] +makeAdaptorAndInstance' = makeAdaptorAndInstanceI Nothing -appArrow :: Type -> Type -> Type -appArrow l r = appTAll ArrowT [l, r] diff --git a/Test/CheckTypes.hs b/Test/CheckTypes.hs --- a/Test/CheckTypes.hs +++ b/Test/CheckTypes.hs @@ -4,7 +4,9 @@ import Data.Profunctor.Product.Default (Default, def) import Definitions (Data2, Data3, Record2, Record3, - pData2, pData3, pRecord2, pRecord3) + RecordDefaultName, + pData2, pData3, pRecord2, pRecord3, + pRecordDefaultName) -- 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 @@ -45,3 +47,6 @@ Default p a a', Default p b b', Default p c c') => p (Record3 a b c) (Record3 a' b' c') instanceRecord3 = def + +defaultNameGenerated :: ProductProfunctor p => RecordDefaultName (p x x') (p y y') -> p (RecordDefaultName x y) (RecordDefaultName x' y') +defaultNameGenerated = pRecordDefaultName diff --git a/Test/Definitions.hs b/Test/Definitions.hs --- a/Test/Definitions.hs +++ b/Test/Definitions.hs @@ -8,7 +8,7 @@ -- because we want to ensure that no external names are required to be -- imported. -import Data.Profunctor.Product.TH (makeAdaptorAndInstance) +import Data.Profunctor.Product.TH (makeAdaptorAndInstance, makeAdaptorAndInstance') data Data2 a b = Data2 a b data Data3 a b c = Data3 a b c @@ -16,7 +16,10 @@ data Record2 a b = Record2 { a2 :: a, b2 :: b } data Record3 a b c = Record3 { a3 :: a, b3 :: b, c3 :: c } +data RecordDefaultName x y = RecordDefaultName { x :: x, y :: y } + $(makeAdaptorAndInstance "pData2" ''Data2) $(makeAdaptorAndInstance "pData3" ''Data3) $(makeAdaptorAndInstance "pRecord2" ''Record2) $(makeAdaptorAndInstance "pRecord3" ''Record3) +makeAdaptorAndInstance' ''RecordDefaultName 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.3.1 +version: 0.7.0.2 synopsis: product-profunctors description: Product profunctors homepage: https://github.com/tomjaguarpaw/product-profunctors @@ -17,12 +17,14 @@ library build-depends: base >= 4.5 && < 5 - , profunctors >= 4.0 && < 5.2 - , contravariant >= 0.4 && < 1.4 + , profunctors >= 4.0 && < 5.3 + , contravariant >= 0.4 && < 1.5 , template-haskell exposed-modules: Data.Profunctor.Product, Data.Profunctor.Product.Default, Data.Profunctor.Product.Flatten, + Data.Profunctor.Product.Internal.TH, + Data.Profunctor.Product.Newtype, Data.Profunctor.Product.TH, Data.Profunctor.Product.Tuples ghc-options: -Wall