product-profunctors 0.10.0.0 → 0.10.0.1

raw patch · 8 files changed

+212/−88 lines, 8 filesdep ~template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +2/−0
• Data/Profunctor/Product/Examples.hs +117/−0
• Data/Profunctor/Product/Internal/TH.hs +82/−78
• Data/Profunctor/Product/TH.hs +0/−1
• Data/Profunctor/Product/Tuples/TH.hs +2/−1
• LICENSE +1/−1
• README.md +1/−1
• product-profunctors.cabal +7/−6

@@ -1,3 +1,5 @@+* Added `Data.Profunctor.Product.Examples`+ # 0.10.0.0  * Removed `ProductContravariant`, `AndArrow`, `defaultContravariantProduct`,

@@ -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+  (****) = (<*>)

@@ -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 []

@@ -146,4 +146,3 @@ -- the string \"p\". makeAdaptorAndInstance' :: TH.Name -> TH.Q [TH.Dec] makeAdaptorAndInstance' = makeAdaptorAndInstanceI Nothing-

@@ -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

@@ -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. 

@@ -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 

@@ -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,