invariant 0.3.1 → 0.4

raw patch · 6 files changed

+98/−35 lines, 6 filesdep +comonadPVP ok

version bump matches the API change (PVP)

Dependencies added: comonad

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• LICENSE +1/−1
• invariant.cabal +2/−1
• src/Data/Functor/Invariant.hs +48/−3
• src/Data/Functor/Invariant/TH.hs +37/−29
• src/Data/Functor/Invariant/TH/Internal.hs +2/−1

@@ -1,3 +1,11 @@+# 0.4+* Allow TH derivation of `Invariant(2)` instances for datatypes containing+  unboxed tuple types+* Ensure `Invariant(2)` instances are in-scope when importing+  `Data.Functor.Invariant`+* Add `Invariant` and `Invariant2` instances for `Kleisli` and `Cokleisli`+* Add `Category` and `Arrow`-like instances for `WrappedProfunctor`+ # 0.3.1 * Rewrote `Data.Functor.Invariant.TH`'s type inferencer. This avoids a nasty   GHC 7.8-specific bug involving derived `Invariant(2)` instances for data

@@ -1,4 +1,4 @@-Copyright (c) 2012, University of Kansas+Copyright (c) 2012-2016, University of Kansas All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -1,5 +1,5 @@ name:                invariant-version:             0.3.1+version:             0.4 synopsis:            Haskell 98 invariant functors description:         Haskell 98 invariant functors category:            Control, Data@@ -33,6 +33,7 @@   build-depends:       array                >= 0.3    && < 0.6                      , base                 >= 4      && < 5                      , bifunctors           >= 5.2    && < 6+                     , comonad              >= 5      && < 6                      , containers           >= 0.1    && < 0.6                      , contravariant        >= 0.5    && < 2                      , ghc-prim

@@ -16,7 +16,7 @@  {-| Module:      Data.Functor.Invariant-Copyright:   (C) 2012-2015 Nicolas Frisby, (C) 2015 Ryan Scott+Copyright:   (C) 2012-2016 Nicolas Frisby, (C) 2015-2016 Ryan Scott License:     BSD-style (see the file LICENSE) Maintainer:  Ryan Scott Portability: Portable@@ -49,9 +49,10 @@   ) where  -- base-import qualified Control.Category as Cat-import           Control.Arrow hiding (first) import           Control.Applicative as App+import qualified Control.Arrow as Arr+import           Control.Arrow hiding (first, second)+import qualified Control.Category as Cat import           Control.Exception (Handler(..)) import           Control.Monad (MonadPlus(..), liftM) import qualified Control.Monad.ST as Strict (ST)@@ -100,6 +101,9 @@ import           Data.Bifunctor.Tannen import           Data.Bifunctor.Wrapped +-- comonad+import           Control.Comonad (Comonad(..), Cokleisli(..), liftW)+ -- containers import           Data.IntMap (IntMap) import           Data.Map (Map)@@ -221,6 +225,9 @@ #endif   => Invariant (ArrowMonad a) where   invmap f _ (ArrowMonad m) = ArrowMonad (m >>> arr f)+-- | from "Control.Arrow"+instance Monad m => Invariant (Kleisli m a) where+  invmap = invmap2 id id  -- | from "Control.Exception" instance Invariant Handler where@@ -348,6 +355,10 @@ instance Bifunctor p => Invariant (WrappedBifunctor p a) where   invmap = invmap2 id id +-- | from the @comonad@ package+instance Invariant (Cokleisli w a) where+  invmap = invmapFunctor+ -- | from the @containers@ package instance Invariant IntMap where   invmap = invmapFunctor@@ -657,6 +668,10 @@ instance Arrow arr => Invariant2 (App.WrappedArrow arr) where   invmap2 _ f' g _ (App.WrapArrow x) = App.WrapArrow $ arr g Cat.. x Cat.. arr f' +-- | from "Control.Arrow"+instance Monad m => Invariant2 (Kleisli m) where+  invmap2 _ f' g _ (Kleisli m) = Kleisli $ liftM g . m . f'+ -- | from "Data.Semigroup" instance Invariant2 Arg where   invmap2 = invmap2Bifunctor@@ -690,6 +705,10 @@ instance Bifunctor p => Invariant2 (WrappedBifunctor p) where   invmap2 = invmap2Bifunctor +-- | from the @comonad@ package+instance Comonad w => Invariant2 (Cokleisli w) where+   invmap2 _ f' g _ (Cokleisli w) = Cokleisli $ g . w . liftW f'+ -- | from the @contravariant@ package instance Invariant2 Op where   invmap2 f f' g g' (Op x) = Op $ invmap2 g g' f f' x@@ -796,6 +815,32 @@   rmap g    = WrapProfunctor . rmap g    . unwrapProfunctor   WrapProfunctor x .# f = WrapProfunctor (x .# f)   g #. WrapProfunctor x = WrapProfunctor (g #. x)++instance Cat.Category p => Cat.Category (WrappedProfunctor p) where+  id = WrapProfunctor Cat.id+  WrapProfunctor p1 . WrapProfunctor p2 = WrapProfunctor (p1 Cat.. p2)++instance Arrow p => Arrow (WrappedProfunctor p) where+  arr    = WrapProfunctor . arr+  first  = WrapProfunctor . Arr.first  . unwrapProfunctor+  second = WrapProfunctor . Arr.second . unwrapProfunctor+  WrapProfunctor p1 *** WrapProfunctor p2 = WrapProfunctor (p1 *** p2)+  WrapProfunctor p1 &&& WrapProfunctor p2 = WrapProfunctor (p1 &&& p2)++instance ArrowZero p => ArrowZero (WrappedProfunctor p) where+  zeroArrow = WrapProfunctor zeroArrow++instance ArrowPlus p => ArrowPlus (WrappedProfunctor p) where+  WrapProfunctor p1 <+> WrapProfunctor p2 = WrapProfunctor (p1 <+> p2)++instance ArrowChoice p => ArrowChoice (WrappedProfunctor p) where+  left  = WrapProfunctor . left  . unwrapProfunctor+  right = WrapProfunctor . right . unwrapProfunctor+  WrapProfunctor p1 +++ WrapProfunctor p2 = WrapProfunctor (p1 +++ p2)+  WrapProfunctor p1 ||| WrapProfunctor p2 = WrapProfunctor (p1 ||| p2)++instance ArrowLoop p => ArrowLoop (WrappedProfunctor p) where+  loop = WrapProfunctor . loop . unwrapProfunctor  instance Strong p => Strong (WrappedProfunctor p) where   first'  = WrapProfunctor . first'  . unwrapProfunctor

@@ -2,7 +2,7 @@  {-| Module:      Data.Functor.Invariant.TH-Copyright:   (C) 2012-2015 Nicolas Frisby, (C) 2015 Ryan Scott+Copyright:   (C) 2012-2016 Nicolas Frisby, (C) 2015-2016 Ryan Scott License:     BSD-style (see the file LICENSE) Maintainer:  Ryan Scott Portability: Template Haskell@@ -345,37 +345,45 @@         mentionsTyArgs :: Bool         mentionsTyArgs = any (`mentionsName` tyVarNames) tyArgs -        makeInvmapTuple :: Type -> Name -> Q Exp-        makeInvmapTuple fieldTy fieldName =+        makeInvmapTuple :: ([Q Pat] -> Q Pat) -> ([Q Exp] -> Q Exp) -> Int -> Q Exp+        makeInvmapTuple mkTupP mkTupE n = do+            x  <- newName "x"+            xs <- newNameList "x" n+            lamE [varP x] $ caseE (varE x)+                [ match (mkTupP $ map varP xs)+                        (normalB . mkTupE $ zipWith makeInvmapTupleField tyArgs xs)+                        []+                ]++        makeInvmapTupleField :: Type -> Name -> Q Exp+        makeInvmapTupleField fieldTy fieldName =             appE (makeInvmapForType iClass conName tvMap covariant fieldTy) $ varE fieldName       in case tyCon of-             ArrowT | mentionsTyArgs ->-                 let [argTy, resTy] = tyArgs-                  in do x <- newName "x"-                        b <- newName "b"-                        lamE [varP x, varP b] $-                          makeInvmapForType iClass conName tvMap covariant resTy `appE` (varE x `appE`-                            (makeInvmapForType iClass conName tvMap (not covariant) argTy `appE` varE b))-             TupleT n | n > 0 && mentionsTyArgs -> do-                 x  <- newName "x"-                 xs <- newNameList "x" n-                 lamE [varP x] $ caseE (varE x)-                     [ match (tupP $ map varP xs)-                             (normalB . tupE $ zipWith makeInvmapTuple tyArgs xs)-                             []-                     ]-             _ -> do-                 itf <- isTyFamily tyCon-                 if any (`mentionsName` tyVarNames) lhsArgs || (itf && mentionsTyArgs)-                      then outOfPlaceTyVarError conName tyVarNames-                      else if any (`mentionsName` tyVarNames) rhsArgs-                           then appsE $-                                ( varE (invmapName (toEnum numLastArgs))-                                : doubleMap (makeInvmapForType iClass conName tvMap) rhsArgs-                                )-                           else do x <- newName "x"-                                   lamE [varP x] $ varE x+          ArrowT | mentionsTyArgs ->+              let [argTy, resTy] = tyArgs+               in do x <- newName "x"+                     b <- newName "b"+                     lamE [varP x, varP b] $+                       makeInvmapForType iClass conName tvMap covariant resTy `appE` (varE x `appE`+                         (makeInvmapForType iClass conName tvMap (not covariant) argTy `appE` varE b))+#if MIN_VERSION_template_haskell(2,6,0)+          UnboxedTupleT n+            | n > 0 && mentionsTyArgs -> makeInvmapTuple unboxedTupP unboxedTupE n+#endif+          TupleT n+            | n > 0 && mentionsTyArgs -> makeInvmapTuple tupP tupE n+          _ -> do+              itf <- isTyFamily tyCon+              if any (`mentionsName` tyVarNames) lhsArgs || (itf && mentionsTyArgs)+                   then outOfPlaceTyVarError conName tyVarNames+                   else if any (`mentionsName` tyVarNames) rhsArgs+                        then appsE $+                             ( varE (invmapName (toEnum numLastArgs))+                             : doubleMap (makeInvmapForType iClass conName tvMap) rhsArgs+                             )+                        else do x <- newName "x"+                                lamE [varP x] $ varE x  ------------------------------------------------------------------------------- -- Template Haskell reifying and AST manipulation

@@ -2,7 +2,7 @@  {-| Module:      Data.Functor.Invariant.TH.Internal-Copyright:   (C) 2012-2015 Nicolas Frisby, (C) 2015 Ryan Scott+Copyright:   (C) 2012-2016 Nicolas Frisby, (C) 2015-2016 Ryan Scott License:     BSD-style (see the file LICENSE) Maintainer:  Ryan Scott Portability: Template Haskell@@ -14,6 +14,7 @@ import           Control.Monad (liftM)  import           Data.Foldable (foldr')+import           Data.Functor.Invariant () -- To import the instances import           Data.List import qualified Data.Map as Map (fromList, findWithDefault, singleton) import           Data.Map (Map)