product-profunctors 0.6.3.1 → 0.7.0.2
raw patch · 7 files changed
+418/−294 lines, 7 files
Files
- Data/Profunctor/Product.hs +18/−1
- Data/Profunctor/Product/Internal/TH.hs +268/−0
- Data/Profunctor/Product/Newtype.hs +10/−0
- Data/Profunctor/Product/TH.hs +107/−288
- Test/CheckTypes.hs +6/−1
- Test/Definitions.hs +4/−1
- product-profunctors.cabal +5/−3
Data/Profunctor/Product.hs view
@@ -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 ()
+ Data/Profunctor/Product/Internal/TH.hs view
@@ -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 []
+ Data/Profunctor/Product/Newtype.hs view
@@ -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
Data/Profunctor/Product/TH.hs view
@@ -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]
Test/CheckTypes.hs view
@@ -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
Test/Definitions.hs view
@@ -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
product-profunctors.cabal view
@@ -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