diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,5 @@ +* Added `Data.Profunctor.Product.Examples` + # 0.10.0.0 * Removed `ProductContravariant`, `AndArrow`, `defaultContravariantProduct`, diff --git a/Data/Profunctor/Product/Examples.hs b/Data/Profunctor/Product/Examples.hs new file mode 100644 --- /dev/null +++ b/Data/Profunctor/Product/Examples.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Data.Profunctor.Product.Examples where + +import qualified Data.Profunctor as P +import qualified Data.Profunctor.Product as PP +import qualified Data.Profunctor.Product.Default as D +import Control.Applicative (Applicative, liftA2, pure, (<*>)) + +newtype Replicator r f a b = Replicator (r -> f b) + deriving Functor + +instance Applicative f => D.Default (Replicator (f b) f) b b where + def = Replicator id + +-- | A higher-order generalisation of 'Prelude.replicate'. For +-- example +-- +-- @ +-- foo :: IO (String, String, String) +-- foo = replicateT getLine +-- @ +-- +-- @ +-- > foo +-- Hello +-- world +-- ! +-- (\"Hello\",\"world\",\"!\") +-- @ +replicateT :: D.Default (Replicator r f) b b => r -> f b +replicateT = f + where Replicator f = def' + def' :: D.Default p a a => p a a + def' = D.def + +-- Boilerplate that is derivable using generics but I never got round +-- to implementing it. +instance Applicative f => Applicative (Replicator r f a) where + pure = Replicator . pure . pure + Replicator f <*> Replicator x = Replicator (liftA2 (<*>) f x) + +instance Functor f => P.Profunctor (Replicator r f) where + dimap _ h (Replicator f) = Replicator ((fmap . fmap) h f) + +instance Applicative f=> PP.ProductProfunctor (Replicator r f) where + purePP = pure + (****) = (<*>) + +-- In the real world this would be 'StateT [a] Maybe b' but I don't want to +-- pick up the transformers dependency here +newtype Take a z b = Take ([a] -> Maybe ([a], b)) + deriving Functor + +instance D.Default (Take a) z a where + def = Take (\as -> + case as of + [] -> Nothing + (a:as') -> Just (as', a)) + +-- | A type safe generalisation of 'Prelude.take'. For example +-- +-- @ +-- > let count = [1..] :: [Int] +-- > takeT count :: Maybe (Int, Int) +-- Just (1,2) +-- > takeT count +-- :: Maybe (Int, Int, (Int, (Int, Int), Int, Int), +-- Const Int Bool, Identity (Int, Int), Tagged String Int) +-- Just (1,2,(3,(4,5),6,7),Const 8,Identity (9,10),Tagged 11) +-- @ +takeT :: D.Default (Take a) b b + => [a] + -> Maybe b +takeT = takeExplicit D.def + where takeExplicit :: Take a b b -> [a] -> Maybe b + takeExplicit (Take f) as = fmap snd (f as) + +-- More boilerplate +instance Applicative (Take a z) where + pure x = Take (\as -> pure (as, x)) + Take f <*> Take x = Take (\as -> do + (as', f') <- f as + (as'', x') <- x as' + + return (as'', f' x')) + +instance P.Profunctor (Take a) where + dimap _ g (Take h) = Take ((fmap . fmap . fmap) g h) + +instance PP.ProductProfunctor (Take a) where + purePP = pure + (****) = (<*>) + +newtype Traverse f a b = Traverse { runTraverse :: a -> f b } deriving Functor + +traverseT :: D.Default (Traverse f) a b => a -> f b +traverseT = runTraverse D.def + +instance D.Default (Traverse f) (f a) a where + def = Traverse id + +-- Boilerplate that is derivable using generics but I never got round +-- to implementing it. +instance Applicative f => Applicative (Traverse f a) where + pure = Traverse . pure . pure + Traverse f <*> Traverse x = Traverse (liftA2 (<*>) f x) + +instance Functor f => P.Profunctor (Traverse f) where + dimap g h (Traverse f) = Traverse (P.dimap g (fmap h) f) + +instance Applicative f => PP.ProductProfunctor (Traverse f) where + purePP = pure + (****) = (<*>) diff --git a/Data/Profunctor/Product/Internal/TH.hs b/Data/Profunctor/Product/Internal/TH.hs --- a/Data/Profunctor/Product/Internal/TH.hs +++ b/Data/Profunctor/Product/Internal/TH.hs @@ -11,13 +11,14 @@ mkName, newName, nameBase, TyVarBndr(PlainTV, KindedTV), Con(RecC, NormalC), Clause(Clause), - Type(VarT, ForallT, AppT, ArrowT, ConT), + Type(VarT, ForallT, AppT, ConT), Body(NormalB), Q, classP, - Exp(ConE, VarE, InfixE, AppE, TupE, LamE), + Exp(ConE, VarE, AppE, TupE, LamE), Pat(TupP, VarP, ConP), Name, - Info(TyConI), reify) + Info(TyConI), reify, conE, conT, varE, varP, + instanceD) import Control.Monad ((<=<)) -import Control.Applicative (pure) +import Control.Applicative (pure, liftA2, (<$>), (<*>)) import Control.Arrow (second) makeAdaptorAndInstanceI :: Maybe String -> Name -> Q [Dec] @@ -42,22 +43,22 @@ defaultAdaptorName = (mkName . ("p" ++) . nameBase) conName adaptorNameN = maybe defaultAdaptorName mkName adaptorNameM adaptorSig' = adaptorSig tyName numTyVars adaptorNameN - adaptorDefinition' = - case conTys of ConTys _ -> - adaptorDefinition numTyVars conName adaptorNameN - FieldTys fieldTys -> - adaptorDefinitionFields conName fieldTys adaptorNameN + adaptorDefinition' = case conTys of + ConTys _ -> adaptorDefinition numTyVars conName + FieldTys fieldTys -> adaptorDefinitionFields conName fieldTys instanceDefinition' = instanceDefinition tyName numTyVars numConTys adaptorNameN conName newtypeInstance' = if numConTys == 1 then newtypeInstance conName tyName - else + else return [] return $ do - as <- sequence [adaptorSig', pure adaptorDefinition', instanceDefinition'] + as <- sequence [ adaptorSig' + , adaptorDefinition' adaptorNameN + , instanceDefinition'] ns <- newtypeInstance' return (as ++ ns) @@ -67,15 +68,14 @@ let body = [ FunD 'N.constructor [simpleClause (NormalB (ConE conName))] , FunD 'N.field [simpleClause (NormalB (LamE [ConP conName [VarP x]] (VarE x)))] ] -#if __GLASGOW_HASKELL__ >= 800 - return [InstanceD Nothing [] (ConT ''N.Newtype `AppT` ConT tyName) body] -#else - return [InstanceD [] (ConT ''N.Newtype `AppT` ConT tyName) body] -#endif + i <- instanceD (pure []) + [t| $(conT ''N.Newtype) $(conT tyName) |] + (map pure body) + pure [i] -data ConTysFields = ConTys [Name] +data ConTysFields = ConTys [Type] -- ^^ The type of each constructor field - | FieldTys [(Name, Name)] + | FieldTys [(Name, Type)] -- ^^ The fieldname and type of each constructor field lengthCons :: ConTysFields -> Int @@ -119,23 +119,15 @@ } 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, ConTysFields) conStuffOfConstructor (NormalC conName st) = do - conTys <- mapM (varNameOfType . snd) st - return (conName, ConTys conTys) + return (conName, ConTys (map snd st)) conStuffOfConstructor (RecC conName vst) = do - conTys <- mapM nameType vst - return (conName, FieldTys conTys) - where nameType (n, _, VarT t) = Right (n, t) - nameType (_, _, x) = Left ("Found a non-variable type " ++ show x) + return (conName, FieldTys (map (\(n, _, t) -> (n, t)) vst)) conStuffOfConstructor _ = Left "I can't deal with your constructor type" @@ -150,19 +142,21 @@ instanceDefinition :: Name -> Int -> Int -> Name -> Name -> Q Dec instanceDefinition tyName' numTyVars numConVars adaptorName' conName=instanceDec - where instanceDec = fmap + where instanceDec = liftA2 #if __GLASGOW_HASKELL__ >= 800 - (\i -> InstanceD Nothing i instanceType [defDefinition]) + (\i j -> InstanceD Nothing i j [defDefinition]) #else - (\i -> InstanceD i instanceType [defDefinition]) + (\i j -> InstanceD i j [defDefinition]) #endif - instanceCxt + instanceCxt instanceType + p = varTS "p" + instanceCxt = mapM (uncurry classP) (pClass:defClasses) pClass :: Monad m => (Name, [m Type]) - pClass = (''ProductProfunctor, [return (varTS "p")]) + pClass = (''ProductProfunctor, [return p]) defaultPredOfVar :: String -> (Name, [Type]) - defaultPredOfVar fn = (''Default, [varTS "p", + defaultPredOfVar fn = (''Default, [p, mkTySuffix "0" fn, mkTySuffix "1" fn]) @@ -172,8 +166,11 @@ pArg :: String -> Type pArg s = pArg' tyName' s numTyVars - instanceType = appTAll (ConT ''Default) - [varTS "p", pArg "0", pArg "1"] + instanceType = [t| $(conT ''Default) + $(pure $ p) + $(pure $ pArg "0") + $(pure $ pArg "1") + |] defDefinition = FunD 'def [simpleClause defBody] defBody = NormalB(VarE adaptorName' `AppE` appEAll (ConE conName) defsN) @@ -181,24 +178,25 @@ 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") + where p = mkName "p" + adaptorType = ForallT scope <$> adaptorCxt <*> adaptorAfterCxt + adaptorAfterCxt = [t| $before -> $after |] + adaptorCxt = fmap (:[]) (classP ''ProductProfunctor [pType]) + before = foldl (liftA2 AppT) (pure (ConT tyName')) pArgs + pType = pure $ VarT p pArgs = map pApp tyVars - pApp :: String -> Type - pApp v = appTAll pType [mkVarTsuffix "0" v, mkVarTsuffix "1" v] + pApp :: String -> Q Type + pApp v = [t| $pType $(mkVarTsuffix "0" v) $(mkVarTsuffix "1" v) |] tyVars = allTyVars numTyVars - pArg :: String -> Type - pArg s = pArg' tyName' s numTyVars + pArg :: String -> Q Type + pArg s = pure $ pArg' tyName' s numTyVars - after = appTAll pType [pArg "0", pArg "1"] + after = [t| $pType $(pArg "0") $(pArg "1") |] - scope = concat [ [PlainTV (mkName "p")] + scope = concat [ [PlainTV p] , map (mkTyVarsuffix "0") tyVars , map (mkTyVarsuffix "1") tyVars ] @@ -272,38 +270,38 @@ ++ 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 +adaptorDefinition :: Int -> Name -> Name -> Q Dec +adaptorDefinition numConVars conName x = fmap (FunD x . pure) clause + where clause = fmap (\b -> Clause [] b wheres) body 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) + toTupleE = varE toTupleN + fromTupleE = varE fromTupleN + theDimap = [| $(varE 'dimap) $toTupleE $fromTupleE |] + pN = varE (tupleAdaptors numConVars) + body = fmap NormalB [| $theDimap . $pN . $toTupleE |] wheres = [toTuple conName (toTupleN, numConVars), fromTuple conName (fromTupleN, numConVars)] -adaptorDefinitionFields :: Name -> [(Name, name)] -> Name -> Dec +adaptorDefinitionFields :: Name -> [(Name, name)] -> Name -> Q Dec adaptorDefinitionFields conName fieldsTys adaptorName = - FunD adaptorName [clause] + fmap (FunD adaptorName . pure) clause where fields = map fst fieldsTys -- TODO: vv f should be generated in Q - fP = VarP (mkName "f") - fE = VarE (mkName "f") - clause = Clause [fP] (NormalB body) [] + fP = varP (mkName "f") + fE = varE (mkName "f") + clause = liftA2 (\fP' b -> Clause [fP'] (NormalB b) []) fP body body = case fields of [] -> error "Can't handle no fields in constructor" - field1:fields' -> let first = (VarE '(***$)) `AppE` (ConE conName) - `AppE` (theLmap field1) - app x y = (VarE '(****)) `AppE` x - `AppE` (theLmap y) - in foldl app first fields' + field1:fields' -> + let first = + [| $(varE '(***$)) $(conE conName) $(theLmap field1) |] + app x y = + [| $(varE '(****)) $x $(theLmap y) |] + in foldl app first fields' - theLmap field = appEAll (VarE 'lmap) - [ VarE field - , VarE field `AppE` fE ] + theLmap field = + [| $(varE 'lmap) $(varE field) ($(varE field) $fE) |] xTuple :: ([Pat] -> Pat) -> ([Exp] -> Exp) -> (Name, Int) -> Dec xTuple patCon retCon (funN, numTyVars) = FunD funN [clause] @@ -313,15 +311,27 @@ varPats = map varPS (allTyVars numTyVars) varExps = map varS (allTyVars numTyVars) +tupP :: [Pat] -> Pat +tupP [p] = p +tupP ps = TupP ps + +tupE :: [Exp] -> Exp +tupE [e] = e +tupE es = TupE +#if MIN_VERSION_template_haskell(2,16,0) + $ map Just +#endif + es + fromTuple :: Name -> (Name, Int) -> Dec fromTuple conName = xTuple patCon retCon - where patCon = TupP + where patCon = tupP retCon = appEAll (ConE conName) toTuple :: Name -> (Name, Int) -> Dec toTuple conName = xTuple patCon retCon where patCon = ConP conName - retCon = TupE + retCon = tupE {- Note that we can also do the instance definition like this, but it would @@ -344,9 +354,6 @@ tyNums :: [Int] tyNums = [1..numTyVars] -o :: Exp -> Exp -> Exp -o x y = InfixE (Just x) (varS ".") (Just y) - varS :: String -> Exp varS = VarE . mkName @@ -359,8 +366,8 @@ mkTySuffix :: String -> String -> Type mkTySuffix s = varTS . (++s) -mkVarTsuffix :: String -> String -> Type -mkVarTsuffix s = VarT . mkName . (++s) +mkVarTsuffix :: String -> String -> Q Type +mkVarTsuffix s = pure . VarT . mkName . (++s) varTS :: String -> Type varTS = VarT . mkName @@ -370,9 +377,6 @@ 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/TH.hs b/Data/Profunctor/Product/TH.hs --- a/Data/Profunctor/Product/TH.hs +++ b/Data/Profunctor/Product/TH.hs @@ -146,4 +146,3 @@ -- the string \"p\". makeAdaptorAndInstance' :: TH.Name -> TH.Q [TH.Dec] makeAdaptorAndInstance' = makeAdaptorAndInstanceI Nothing - diff --git a/Data/Profunctor/Product/Tuples/TH.hs b/Data/Profunctor/Product/Tuples/TH.hs --- a/Data/Profunctor/Product/Tuples/TH.hs +++ b/Data/Profunctor/Product/Tuples/TH.hs @@ -129,7 +129,8 @@ 1 -> mkPT (head as) (head bs) _ -> foldl appT (tupleT n) (zipWith mkPT as bs) mkRightTy = varT p `appT` mkTupT as `appT` mkTupT bs - mkTupT = foldl appT (tupleT n) . map varT + mkTupT [v] = varT v + mkTupT vs = foldl appT (tupleT n) (map varT vs) mkPT a b = varT p `appT` varT a `appT` varT b fun = funD nm [ clause [] (normalB bdy) [] ] bdy = varE 'convert `appE` unflat `appE` unflat `appE` flat `appE` pT diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013, Karamaan Group LLC; 2014-2018 Purely Agile Limited +Copyright (c) 2013, Karamaan Group LLC; 2014-2018 Purely Agile Limited; 2019-2020 Tom Ellis All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# product-profunctors [![Hackage version](https://img.shields.io/hackage/v/product-profunctors.svg?label=Hackage)](https://hackage.haskell.org/package/product-profunctors) [![Linux Build Status](https://img.shields.io/travis/tomjaguarpaw/product-profunctors/master.svg?label=Linux%20build)](https://travis-ci.org/tomjaguarpaw/product-profunctors) +# product-profunctors [![Hackage version](https://img.shields.io/hackage/v/product-profunctors.svg?label=Hackage)](https://hackage.haskell.org/package/product-profunctors) [![Linux build status](https://img.shields.io/travis/tomjaguarpaw/product-profunctors/master.svg?label=Linux%20build)](https://travis-ci.org/tomjaguarpaw/product-profunctors) ## Backup maintainers diff --git a/product-profunctors.cabal b/product-profunctors.cabal --- a/product-profunctors.cabal +++ b/product-profunctors.cabal @@ -1,8 +1,8 @@ name: product-profunctors -copyright: Copyright (c) 2013, Karamaan Group LLC; 2014-2018 Purely Agile Limited -version: 0.10.0.0 +copyright: Copyright (c) 2013, Karamaan Group LLC; 2014-2018 Purely Agile Limited; 2019-2020 Tom Ellis +version: 0.10.0.1 synopsis: product-profunctors -description: Product profunctors +description: Product profunctors and tools for working with them homepage: https://github.com/tomjaguarpaw/product-profunctors bug-reports: https://github.com/tomjaguarpaw/product-profunctors/issues license: BSD3 @@ -12,7 +12,7 @@ category: Control, Category build-type: Simple cabal-version: >= 1.18 -tested-with: GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3 +tested-with: GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2 extra-doc-files: README.md CHANGELOG.md @@ -24,14 +24,15 @@ library default-language: Haskell2010 build-depends: base >= 4.5 && < 5 - , profunctors >= 5 && < 5.3 + , profunctors >= 5 && < 5.6 , bifunctors >= 5.4 && < 6.0 - , contravariant >= 0.4 && < 1.5 + , contravariant >= 0.4 && < 1.6 , tagged >= 0.0 && < 1 , template-haskell exposed-modules: Data.Profunctor.Product, Data.Profunctor.Product.Adaptor Data.Profunctor.Product.Default, + Data.Profunctor.Product.Examples, Data.Profunctor.Product.Flatten, Data.Profunctor.Product.Internal.Adaptor Data.Profunctor.Product.Internal.TH,