packages feed

vinyl-plus (empty) → 0.1.0.0

raw patch · 17 files changed

+998/−0 lines, 17 filesdep +basedep +contravariantdep +doctestsetup-changed

Dependencies added: base, contravariant, doctest, ghc-prim, profunctors, transformers, unordered-containers, vinyl

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2015++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/Tagged/Functor.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Tagged.Functor where++import           Data.Proxy+import           Data.Tuple.TypeLevel (Fst, Snd)+import           Data.Vinyl.Core+import           GHC.TypeLits+import           Data.Functor.Identity (Identity(..))++newtype TaggedFunctor (f :: b -> *) (x :: (a,b)) =+  TaggedFunctor { getTaggedFunctor :: f (Snd x) }+instance Eq (f (Snd x)) => Eq (TaggedFunctor f x) where+  TaggedFunctor a == TaggedFunctor b = a == b+instance Ord (f (Snd x)) => Ord (TaggedFunctor f x) where+  compare (TaggedFunctor a) (TaggedFunctor b) = compare a b+instance Show (f (Snd x)) => Show (TaggedFunctor f x) where+  show (TaggedFunctor f) = "TaggedFunctor (" ++ show f ++ ")"++showSymbolTaggedFunctor :: forall f x. (KnownSymbol (Fst x), Show (f (Snd x)))+  => TaggedFunctor f x -> String+showSymbolTaggedFunctor (TaggedFunctor f) =+  (symbolVal (Proxy :: Proxy (Fst x))) ++ ": " ++ show f++tagIdentity :: proxy k -> v -> TaggedFunctor Identity '(k,v)+tagIdentity _ v = TaggedFunctor (Identity v)++tagFunctor :: proxy k -> f v -> TaggedFunctor f '(k,v)+tagFunctor _ f = TaggedFunctor f++untagFunctor :: TaggedFunctor f x -> f (Snd x)+untagFunctor (TaggedFunctor f) = f++liftTaggedFunctor :: (f v -> a) -> TaggedFunctor f '(k,v) -> a+liftTaggedFunctor g (TaggedFunctor f) = g f++rtraverseTagged+  :: Applicative h+  => (forall x. f x -> h (g x))+  -> Rec (TaggedFunctor f) rs+  -> h (Rec (TaggedFunctor g) rs)+rtraverseTagged _ RNil      = pure RNil+rtraverseTagged f (TaggedFunctor x :& xs) =+  (:&) <$> fmap TaggedFunctor (f x) <*> rtraverseTagged f xs+{-# INLINABLE rtraverseTagged #-}++rtraverseIdentityTagged :: Applicative f+  => Rec (TaggedFunctor f) rs+  -> f (Rec (TaggedFunctor Identity) rs)+rtraverseIdentityTagged = rtraverseTagged (fmap Identity)+{-# INLINABLE rtraverseIdentityTagged #-}+
+ src/Data/Tuple/TypeLevel.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE FlexibleInstances    #-}++{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Tuple.TypeLevel where++import           Data.Proxy+import           GHC.Exts   (Constraint)++-- | First element of a type pair.+type family Fst (k :: (m,n)) where+    Fst '(a,b) = a++-- |Second element of a type pair.+type family Snd (k :: (m,n)) where+    Snd '(a,b) = b++class c (Fst x) => ConstrainFst (c :: j -> Constraint) (x :: (j,k))+instance c (Fst x) => ConstrainFst c x++class c (Snd x) => ConstrainSnd (c :: k -> Constraint) (x :: (j,k))+instance c (Snd x) => ConstrainSnd c x++proxyFst :: proxy x -> Proxy (Fst x)+proxyFst _ = Proxy++proxySnd :: proxy x -> Proxy (Snd x)+proxySnd _ = Proxy+
+ src/Data/TypeMap.hs view
@@ -0,0 +1,75 @@+module Data.TypeMap+  ( TypeMap+  , empty+  , insert+  , lookup+  , lookup'+  ) where++import Prelude hiding (lookup)+import Data.Typeable+import qualified Data.HashMap.Strict as HashMap+import Data.HashMap.Strict (HashMap)+import GHC.Prim (Any)+import Unsafe.Coerce (unsafeCoerce)++newtype TypeMap (f :: * -> *) = +  TypeMap { getTypeMap :: HashMap TypeRep Any }++empty :: TypeMap f+empty = TypeMap HashMap.empty++insert :: Typeable a => f a -> TypeMap f -> TypeMap f+insert fa (TypeMap m) = +  TypeMap (HashMap.insert (typeRep fa) (toAny2 fa) m)++lookup :: forall a f . Typeable a => TypeMap f -> Maybe (f a)+lookup = lookup' (Proxy :: Proxy a)++lookup' :: Typeable a => proxy a -> TypeMap f -> Maybe (f a)+lookup' p (TypeMap m) = fmap fromAny2 (HashMap.lookup (typeRep p) m)++map :: (forall a. f a -> g a) -> TypeMap f -> TypeMap g+map f (TypeMap m) = TypeMap (HashMap.map (toAny2 . f . fromAny2) m)++toAny2 :: f a -> Any+toAny2 = unsafeCoerce++fromAny2 :: Any -> f a+fromAny2 = unsafeCoerce++toAny :: a -> Any+toAny = unsafeCoerce++fromAny :: Any -> a+fromAny = unsafeCoerce++-- module Data.TypeMap +--   ( TypeMap+--   , insert+--   , lookup+--   , lookup'+--   ) where+-- +-- import Prelude hiding (lookup)+-- import Data.Typeable+-- import qualified Data.HashMap.Strict as HashMap+-- import Data.HashMap.Strict (HashMap)+-- import GHC.Prim (Any)+-- import Unsafe.Coerce (unsafeCoerce)+-- +-- newtype TypeMap = TypeMap { getTypeMap :: HashMap TypeRep Any }+-- +-- insert :: Typeable a => a -> TypeMap -> TypeMap+-- insert a (TypeMap m) = +--   TypeMap (HashMap.insert (typeOf a) (unsafeCoerce a) m)+-- +-- lookup :: forall a. Typeable a => TypeMap -> Maybe a+-- lookup = lookup' (Proxy :: Proxy a)+-- +-- lookup' :: Typeable a => proxy a -> TypeMap -> Maybe a+-- lookup' p (TypeMap m) = fmap unsafeCoerce (HashMap.lookup (typeRep p) m)+-- +-- -- modify :: Typeable a => (a -> a) -> TypeMap -> TypeMap+-- -- modify +
+ src/Data/Vinyl/Optic/Plain/Class.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}++module Data.Vinyl.Optic.Plain.Class where++import           Data.Profunctor.Choice    (Choice)+import           Data.Vinyl.Core+import           Data.Vinyl.Plus.Internal  (prism')+import           Data.Vinyl.Plus.TypeLevel+import           Data.Vinyl.TypeLevel+import           Data.Vinyl.Types++-- | This is a drop-in replacement for the 'RElem' class from @Data.Vinyl.Lens@.+--   The functions it provides work on 'CoRec's instead of 'Rec's.+--   It also provides a lifting function 'clift', which has no+--   equivalent operation on 'Rec's.+--   If 'CoRec' were merged into @vinyl@, this typeclass could be+--   eliminated, and its methods could be added to 'RElem'.+class i ~ RIndex r rs => RElem (r :: k) (rs :: [k]) (i :: Nat) where+  -- | We can get a prism for getting and setting values in a 'CoRec'. Morally,+  --+  -- > cprism :: Prism' (CoRec f rs) (f r)+  cprism :: (Choice p, Applicative g) => proxy r -> p (f r) (g (f r)) -> p (CoRec f rs) (g (CoRec f rs))+  -- | Get a value from a 'CoRec'. Note that, unlike 'rget',+  --   this function may not find the requested element, so+  --   the result is wrapped in 'Maybe'.+  cget  :: proxy r -> CoRec f rs -> Maybe (f r)+  -- | If the element in the 'CoRec' is of a certain type,+  --   modify it. Otherwise, leave the 'CoRec' unchanged.+  cmodify :: (f r -> f r) -> CoRec f rs -> CoRec f rs+  -- | If the element in the 'CoRec' is of a certain type,+  --   replace it. This function is provided for symmetry+  --   with 'rput', but it is not typically useful.+  --   Usually, 'clift' is more useful.+  cput  :: f r -> CoRec f rs -> CoRec f rs+  -- | Lift an element into a 'CoRec'.+  clift :: f r -> CoRec f rs++instance (r ~ s) => RElem r (s ': rs) 'Z where+  cprism p = prism' clift (cget p)+  clift  = CoRecHere+  cget _ (CoRecHere v)    = Just v+  cget _ (CoRecThere _)   = Nothing+  cput v (CoRecHere _)    = CoRecHere v+  cput _ r@(CoRecThere _) = r+  cmodify f (CoRecHere v)    = CoRecHere (f v)+  cmodify _ r@(CoRecThere _) = r++instance (RIndex r (s ': rs) ~ 'S i, RElem r rs i) => RElem r (s ': rs) ('S i) where+  cprism p = prism' clift (cget p)+  clift v = CoRecThere (clift v)+  cget _ (CoRecHere _)      = Nothing+  cget proxy (CoRecThere c) = cget proxy c+  cput _ r@(CoRecHere _)    = r+  cput v (CoRecThere r) = CoRecThere (cput v r)+  cmodify _ r@(CoRecHere _) = r+  cmodify f (CoRecThere r)  = CoRecThere (cmodify f r)++class is ~ RImage sub super => RSubset (sub :: [k]) (super :: [k]) is where+  -- | Upcast a 'CoRec' to another 'CoRec' that could be+  --   inhabited by additional types.+  ccast :: CoRec f sub -> CoRec f super++instance RSubset '[] super '[] where+  ccast _ = error "CSubset: an empty CoRec is not possible"++instance (RElem r super i , RSubset sub super is) => RSubset (r ': sub) super (i ': is) where+  ccast (CoRecHere v) = clift v+  ccast (CoRecThere cr) = ccast cr++-- | Two record types are equivalent when they are subtypes of each other.+type REquivalent rs ss is js = (RSubset rs ss is, RSubset ss rs js)++-- | A shorthand for 'RElem' which supplies its index.+type RElem' r rs = RElem r rs (RIndex r rs)++-- | An infix operator for 'RMember\''.+type r ∈ rs = RElem' r rs ++-- | A shorthand for 'RSubset' which supplies its image.+type RSubset' rs ss = RSubset rs ss (RImage rs ss)++-- | An infix operator for 'RSubset\''+type rs ⊆ ss = RSubset' rs ss ++-- | A shorthand for 'REquivalent' which supplies its images.+type REquivalent' rs ss = REquivalent rs ss (RImage rs ss) (RImage ss rs)++-- | An infix operator for 'REquivalent\''+type rs ≅ ss = REquivalent' rs ss ++-- | A non-unicode equivalent of @(⊆)@.+type rs <: ss = rs ⊆ ss++-- | A non-unicode equivalent of @(≅)@.+type rs :~: ss = rs ≅ ss++-- type CElem r rs = CElemX r rs (RIndex r rs)+-- type CSubset sub super = CSubsetX sub super (RImage sub super)++-- example :: CoRec Maybe '[Bool,Int,Double]+-- example = clift (Just (4 :: Int))+--+-- example2 :: CoRec Maybe '[Bool,Int] -> CoRec Maybe '[Int,Bool,Char]+-- example2 = ccast+--+-- example3 :: Maybe Int -> CoRec Maybe '[Bool,Int] -> CoRec Maybe '[Bool,Int]+-- example3 = cput+--+-- example4 :: CoRec Maybe '[Bool,Int] -> Maybe (Maybe Int)+-- example4 = cget (Nothing :: Maybe Int)+
+ src/Data/Vinyl/Optic/Tagged/Class.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}++module Data.Vinyl.Optic.Tagged.Class+  ( IxElem(..)+  , rsetBy'+  ) where++import           Data.Functor.Identity     (Identity (..))+import           Data.Tagged.Functor       (TaggedFunctor (..))+import           Data.Vinyl.Core+import           Data.Vinyl.Plus.TypeLevel+import           Data.Vinyl.TypeLevel+import           GHC.Prim                  (Proxy#, proxy#)++-- | This is a typeclass in the spirit of 'RElem' that provides+--   a lens for 'Rec' whose values a tagged by an additional+--   marker (often a 'Symbol'). The methods in this typeclass+--   are not intended to be used directly. Instead, import one+--   of the four submodules, and use the functions it provides.+class (i ~ TIndex a rs, b ~ Lookup a rs) => IxElem (a :: k) (rs :: [(k,v)]) (i :: Nat) (b :: v) where+  rlensBy'   :: Functor g+             => Proxy# a+             -> (f b -> g (f b))+             -> Rec (TaggedFunctor f) rs+             -> g (Rec (TaggedFunctor f) rs)+  rgetBy'    :: Proxy# a -> Rec (TaggedFunctor f) rs -> f b+  rmodifyBy' :: Proxy# a -> (f b -> f b) -> Rec (TaggedFunctor f) rs -> Rec (TaggedFunctor f) rs++instance (r ~ '(k,v)) => IxElem k (r ': rs) 'Z v where+  rlensBy' _ f (TaggedFunctor x :& xs) = fmap ((:& xs) . TaggedFunctor) (f x)+  rgetBy' _ (TaggedFunctor r :& _) = r+  rmodifyBy' _ f (TaggedFunctor r :& rs) = TaggedFunctor (f r) :& rs++instance (TIndex k (s ': rs) ~ 'S i, Lookup k (s ': rs) ~ v, IxElem k rs i v)+    => IxElem k (s ': rs) ('S i) v where+  rlensBy' p f (x :& xs) = fmap (x :&) (rlensBy' p f xs)+  rgetBy' p (_ :& rs) = rgetBy' p rs+  rmodifyBy' p f (r :& rs) = r :& rmodifyBy' p f rs++rsetBy' :: IxElem k rs i v => Proxy# k -> f v -> Rec (TaggedFunctor f) rs -> Rec (TaggedFunctor f) rs+rsetBy' p newVal rec = rmodifyBy' p (const newVal) rec+
+ src/Data/Vinyl/Optic/Tagged/Proxy/Functor.hs view
@@ -0,0 +1,36 @@+-- |+-- This module provides accessors and modifiers for labeled+-- records. As the module name indicates, the functions+-- provided by this module are designed to work with records+-- under the following conditions:+--+--   (1) The @VisibleTypeApplication@ extension is unavailable.+--+-- If you are working with labeled records that use 'Identity'+-- inner functor for 'TaggedFunctor', you should consider+-- using @Data.Vinyl.Optic.Plain.Class.Tagged.Proxy.Identity@ instead.+--+module Data.Vinyl.Optic.Tagged.Proxy.Functor where++import           Data.Tagged.Functor           (TaggedFunctor)+import           Data.Vinyl.Core               (Rec)+import           Data.Vinyl.Optic.Tagged.Class+import           GHC.Prim                      (Proxy#, proxy#)++lens :: forall k g f rs i v proxy. (Functor g, IxElem k rs i v)+  => proxy k -> (f v -> g (f v))+  -> Rec (TaggedFunctor f) rs -> g (Rec (TaggedFunctor f) rs)+lens _ = rlensBy' (proxy# :: Proxy# k)++get :: forall k f rs i v proxy. IxElem k rs i v => proxy k -> Rec (TaggedFunctor f) rs -> f v+get _ = rgetBy' (proxy# :: Proxy# k)++set :: forall k f rs i v proxy. IxElem k rs i v => proxy k -> f v -> Rec (TaggedFunctor f) rs -> Rec (TaggedFunctor f) rs+set _ = rsetBy' (proxy# :: Proxy# k)++modify :: forall k f rs i v proxy. IxElem k rs i v => proxy k -> (f v -> f v) -> Rec (TaggedFunctor f) rs -> Rec (TaggedFunctor f) rs+modify _ = rmodifyBy' (proxy# :: Proxy# k)++++
+ src/Data/Vinyl/Optic/Tagged/Proxy/Identity.hs view
@@ -0,0 +1,82 @@+-- |+-- This module provides accessors and modifiers for labeled+-- records. As the module name indicates, the functions+-- provided by this module are designed to work with records+-- under the following conditions:+--+--   (1) The 'TaggedFunctor' is parameterized by 'Identity'.+--   (2) The @VisibleTypeApplication@ extension is unavailable.+--++module Data.Vinyl.Optic.Tagged.Proxy.Identity+  (+  -- * Functions+    lens+  , get+  , set+  , modify+  -- * Tutorial+  -- $tutorial+  ) where++-- import           Data.Coerce+import           Data.Functor.Identity         (Identity (..))+import           Data.Tagged.Functor           (TaggedFunctor)+import           Data.Vinyl.Core               (Rec)+import           Data.Vinyl.Optic.Tagged.Class+import           GHC.Prim                      (Proxy#, proxy#)++lens :: forall k g rs i v proxy. (Functor g, IxElem k rs i v)+  => proxy k -> (v -> g v)+  -> Rec (TaggedFunctor Identity) rs -> g (Rec (TaggedFunctor Identity) rs)+lens _ conv = rlensBy' (proxy# :: Proxy# k) (fmap Identity . conv . runIdentity)++get :: forall k rs i v proxy. IxElem k rs i v => proxy k -> Rec (TaggedFunctor Identity) rs -> v+get _ rec = runIdentity (rgetBy' (proxy# :: Proxy# k) rec)++set :: forall k rs i v proxy. IxElem k rs i v => proxy k -> v -> Rec (TaggedFunctor Identity) rs -> Rec (TaggedFunctor Identity) rs+set _ newVal rec = rsetBy' (proxy# :: Proxy# k) (Identity newVal) rec++modify :: forall k rs i v proxy. IxElem k rs i v => proxy k -> (v -> v) -> Rec (TaggedFunctor Identity) rs -> Rec (TaggedFunctor Identity) rs+modify _ f rec = rmodifyBy' (proxy# :: Proxy# k) (Identity . f . runIdentity) rec++{- $tutorial++Here is a explanation of how the functions in this module can+be used. First we will create a record:++>>> import Data.Tagged.Functor+>>> import Data.Functor.Identity+>>> import Data.Proxy+>>> import Data.Vinyl.Core+>>> :{+let person = tagIdentity (Proxy :: Proxy "age") (44 :: Int)+          :& tagIdentity (Proxy :: Proxy "name") ("Alexa" :: String)+          :& tagIdentity (Proxy :: Proxy "alive") True+          :& RNil+:}++Notice that the type of @person@ is inferred and fully monomorphic:++>>> :t person+person+  :: Rec+       (TaggedFunctor Identity)+       '['("age", Int), '("name", String), '("alive", Bool)]++The 'Identity' wrappers are cumbersome to deal with. This module+provides extra functions (suffixed with @Id@) that get eliminate some+of the boilerplate. With these functions, the above becomes:++>>> get (Proxy :: Proxy "name") person+"Alexa"+>>> let deceased2 = set (Proxy :: Proxy "alive") False person+>>> get (Proxy :: Proxy "alive") deceased2+False+>>> let older2 = modify (Proxy :: Proxy "age") (+12) person+>>> get (Proxy :: Proxy "age") older2+56++-}++
+ src/Data/Vinyl/Plus/Functor/Prelude.hs view
@@ -0,0 +1,35 @@+module Data.Vinyl.Plus.Functor.Prelude where++import           Prelude                 hiding (foldl, head, tail, unzip, zip,+                                          zip3, zip4)++import           Data.Functor.Constant+import           Data.Functor.Identity+import           Data.Functor.Product+import           Data.Monoid             (Endo (..))+import           Data.Vinyl.Core+import           Data.Vinyl.TypeLevel+import           Data.Vinyl.Types++-- This needs to be imported qualified++head :: FunctorRec (f ': fs) a -> f a+head (FunctorRec (Flap r :& _)) = r++tail :: FunctorRec (f ': fs) a -> FunctorRec fs a+tail (FunctorRec (_ :& rs)) = FunctorRec rs++cons :: f a -> FunctorRec fs a -> FunctorRec (f ': fs) a+cons r (FunctorRec rs) = FunctorRec (Flap r :& rs)++uncons :: FunctorRec (f ': fs) a -> (f a, FunctorRec fs a)+uncons (FunctorRec (Flap r :& rs)) = (r, FunctorRec rs)++append :: FunctorRec fs a -> FunctorRec gs a -> FunctorRec (fs ++ gs) a+append (FunctorRec RNil) gs = gs+append (FunctorRec (f :& fsNext)) gs =+  FunctorRec (f :& getFunctorRec (append (FunctorRec fsNext) gs))++singleton :: f a -> FunctorRec '[f] a+singleton f = FunctorRec (Flap f :& RNil)+
+ src/Data/Vinyl/Plus/Internal.hs view
@@ -0,0 +1,15 @@+module Data.Vinyl.Plus.Internal where++import           Data.Profunctor+import           Data.Profunctor.Choice++-- | This is copied from 'Control.Lens.Prism'.+prism :: (Choice p, Applicative f) => (b -> t) -> (s -> Either t a) -> p a (f b) -> p s (f t)+prism bt seta = dimap seta (either pure (fmap bt)) . right'+{-# INLINE prism #-}++-- | This is copied from 'Control.Lens.Prism'.+prism' :: (Choice p, Applicative f) => (b -> s) -> (s -> Maybe a) -> p a (f b) -> p s (f s)+prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s))+{-# INLINE prism' #-}+
+ src/Data/Vinyl/Plus/TypeLevel.hs view
@@ -0,0 +1,27 @@+-- {-# LANGUAGE UndecidableInstances #-}+module Data.Vinyl.Plus.TypeLevel where++import           GHC.Exts (Constraint)+import           Data.Vinyl.TypeLevel++type family Head (rs :: [k]) :: k where+  Head (r ': rs) = r++type family ListAll (rs :: [k]) (c :: k -> Constraint) :: Constraint where+  ListAll '[] c = ()+  ListAll (a ': as) c = (c a, ListAll as c)++-- | A partial relation that gives the index of a value in a list.+type family Lookup (r :: k) (rs :: [(k,v)]) :: v where+  Lookup k ('(k,v) ': rs) = v+  Lookup k ('(j,v) ': rs) = (Lookup k rs)++-- | A partial relation that gives the index of a value in a list.+type family TIndex (r :: k) (rs :: [(k,v)]) :: Nat where+  TIndex r ( '(r,x) ': rs) = 'Z+  TIndex r ( '(s,x) ': rs) = 'S (TIndex r rs)+++-- type family FstPlusOne a where+--   FstPlusOne '(n,x) = '( 'S n, x)+
+ src/Data/Vinyl/Prelude/CoRec.hs view
@@ -0,0 +1,123 @@+module Data.Vinyl.Prelude.CoRec where++import           Prelude                      hiding (foldl, head, map, tail,+                                               traverse, unzip, zip, zip3, zip4)++import           Data.Functor.Compose+import           Data.Functor.Constant+import           Data.Functor.Contravariant   (Op (..))+import           Data.Functor.Identity+import           Data.Functor.Product+import           Data.Monoid                  (Endo (..))+import           Data.Proxy                   (Proxy (Proxy))+import           Data.Typeable                (Typeable)+import           Data.TypeMap                 (TypeMap)+import qualified Data.TypeMap                 as TypeMap+import           Data.Vinyl.Core+import           Data.Vinyl.Functor           (Lift (..))+import           Data.Vinyl.Optic.Plain.Class+import           Data.Vinyl.Plus.TypeLevel    (ListAll)+import           Data.Vinyl.TypeLevel+import           Data.Vinyl.Types++head :: CoRec f (r ': rs) -> Maybe (f r)+head (CoRecThere _) = Nothing+head (CoRecHere v) = Just v++tail :: CoRec f (r ': rs) -> Maybe (CoRec f rs)+tail (CoRecThere rs) = Just rs+tail (CoRecHere _) = Nothing++cons :: CoRec f rs -> CoRec f (r ': rs)+cons = CoRecThere++uncons :: CoRec f (r ': rs) -> Either (f r) (CoRec f rs)+uncons (CoRecHere v) = Left v+uncons (CoRecThere c) = Right c++apply :: Rec (Lift (->) f g) rs -> CoRec f rs -> CoRec g rs+apply (Lift f :& rs) cr = case cr of+  CoRecHere v -> CoRecHere (f v)+  CoRecThere cr' -> CoRecThere (apply rs cr')++map :: (forall x. f x -> g x) -> CoRec f rs -> CoRec g rs+map f (CoRecHere v)  = CoRecHere (f v)+map f (CoRecThere c) = CoRecThere (map f c)++replace :: Rec f rs -> CoRec f rs -> CoRec f rs+replace (r :& rs) (CoRecHere _)   = CoRecHere r+replace (_ :& rs) (CoRecThere cr) = CoRecThere (replace rs cr)++modify :: Rec (Compose Endo f) rs -> CoRec f rs -> CoRec f rs+modify (Compose (Endo g) :& _) (CoRecHere r) = CoRecHere (g r)+modify (_ :& rs) (CoRecThere cr) = CoRecThere (modify rs cr)++modify' :: Rec Endo rs -> CoRec Identity rs -> CoRec Identity rs+modify' (Endo g :& _) (CoRecHere (Identity r)) = CoRecHere (Identity (g r))+modify' (_ :& rs) (CoRecThere cr) = CoRecThere (modify' rs cr)++-- | There is not a actual traverse function for 'CoRec'. Notice how+--   this does not have an 'Applicative' constraint and consequently+--   does not combine contexts. It is provided for symmetry with the+--   traverse function available for 'Rec'.+traverse :: Functor h => (forall x. f x -> h (g x)) -> CoRec f rs -> h (CoRec g rs)+traverse f (CoRecHere v) = CoRecHere <$> f v+traverse f (CoRecThere v) = CoRecThere <$> traverse f v++coalesce :: CoRec (Constant a) rs -> a+coalesce (CoRecHere (Constant a)) = a+coalesce (CoRecThere cr) = coalesce cr++coalesceWith :: (forall a. f a -> b) -> CoRec f rs -> b+coalesceWith f cr = case cr of+  CoRecHere v -> f v+  CoRecThere cr' -> coalesceWith f cr'++coalesceBy :: Rec (Compose (Op b) f) rs -> CoRec f rs -> b+coalesceBy (Compose (Op f) :& _) (CoRecHere v) = f v+coalesceBy (_ :& rs) (CoRecThere cr) = coalesceBy rs cr++-- | Specialization of 'coalesceBy' that is more convenient for+--   working with an 'Identity'-parameterized 'CoRec'. This function+--   can be used to pattern-match on a 'CoRec':+--+-- >>> import Data.Char (ord)+-- >>> :{+-- let handleVal = coalesceBy'+--        $ Op ord+--       :& Op (id :: Int -> Int)+--       :& Op (\b -> if b then 1 else 0)+--       :& RNil+-- :}+--+-- Now we can reduce any 'CoRec' 'Identity' @'[Char,Int,Bool]@+-- to an @Int@.+--+-- >>> handleVal (lift' True)+-- 1+-- >>> handleVal (lift' (44 :: Int))+-- 44+-- >>> handleVal (lift' 'g')+-- 103+--+coalesceBy' :: Rec (Op b) rs -> CoRec Identity rs -> b+coalesceBy' (Op f :& _) (CoRecHere (Identity v)) = f v+coalesceBy' (_ :& rs) (CoRecThere cr) = coalesceBy' rs cr++lift :: RElem r rs i => f r -> CoRec f rs+lift = clift++lift' :: RElem r rs i => r -> CoRec Identity rs+lift' = clift . Identity++-- match' :: (forall a. a -> b) -> CoRec Identity rs -> b+-- match' f cr = case cr of+--   CoRecHere (Identity v) -> f v+--   CoRecThere cr' -> match' f cr'++just :: CoRec f rs -> CoRec (Compose Maybe f) rs+just = map (Compose . Just)++right :: CoRec f rs -> CoRec (Compose (Either a) f) rs+right = map (Compose . Right)+
+ src/Data/Vinyl/Prelude/Rec.hs view
@@ -0,0 +1,151 @@+module Data.Vinyl.Prelude.Rec where++import           Prelude                   hiding (foldl, head, map, tail,+                                            unzip, zip, zip3, zip4)++import           Data.Functor.Compose+import           Data.Functor.Constant+import           Data.Functor.Identity+import           Data.Functor.Product+import           Data.Monoid               (Endo (..))+import           Data.Proxy                (Proxy (Proxy))+import           Data.Typeable             (Typeable)+import           Data.TypeMap              (TypeMap)+import qualified Data.TypeMap              as TypeMap+import           Data.Vinyl.Core+import           Data.Vinyl.Functor        (Lift (..))+import           Data.Vinyl.Plus.TypeLevel (ListAll)+import           Data.Vinyl.TypeLevel+import           Data.Vinyl.Types++-- This needs to be imported qualified++head :: Rec f (r ': rs) -> f r+head (r :& _) = r++tail :: Rec f (r ': rs) -> Rec f rs+tail (_ :& rs) = rs++cons :: f r -> Rec f rs -> Rec f (r ': rs)+cons = (:&)++uncons :: Rec f (r ': rs) -> (f r, Rec f rs)+uncons (r :& rs) = (r, rs)++curry :: (Rec f (a ': as) -> b) -> f a -> Rec f as -> b+curry f r rs = f (r :& rs)++uncurry :: (f a -> Rec f as -> b) -> Rec f (a ': as) -> b+uncurry f (r :& rs) = f r rs++append :: Rec f rs -> Rec f ss -> Rec f (rs ++ ss)+append = rappend++singleton :: f a -> Rec f '[a]+singleton v = v :& RNil++null :: Rec f rs -> Bool+null RNil = True+null (_ :& _) = False++foldl :: (forall a. b -> f a -> b) -> b -> Rec f rs -> b+foldl _ !acc RNil = acc+foldl f !acc (r :& rs) = foldl f (f acc r) rs++foldlConstrained :: ListAll rs c+  => proxy c -> (forall a. c a => b -> f a -> b)+  -> b -> Rec f rs -> b+foldlConstrained p f acc RNil = acc+foldlConstrained p f acc (r :& rs) = foldlConstrained p f (f acc r) rs++toTypeMap :: ListAll rs Typeable => Rec f rs -> TypeMap f+toTypeMap = foldlConstrained (Proxy :: Proxy Typeable) (flip TypeMap.insert) TypeMap.empty++fromTypeMap :: ListAll rs Typeable+  => Rec proxy rs -> TypeMap f -> Maybe (Rec f rs)+fromTypeMap RNil _ = Just RNil+fromTypeMap (r :& rs) m = (:&) <$> TypeMap.lookup' r m <*> fromTypeMap rs m++fromTypeMap' :: forall f rs. (ListAll rs Typeable, RecApplicative rs) => TypeMap f -> Maybe (Rec f rs)+fromTypeMap' m = fromTypeMap (rpure Proxy :: Rec Proxy rs) m++length :: Rec f rs -> Int+length = foldl (\i _ -> i + 1) 0++apply :: Rec (Lift (->) f g) rs -> Rec f rs -> Rec g rs+apply = rapply++traverse :: Applicative h => (forall x. f x -> h (g x)) -> Rec f rs -> h (Rec g rs)+traverse = rtraverse++replace :: CoRec f rs -> Rec f rs -> Rec f rs+replace (CoRecHere v) (_ :& rs) = v :& rs+replace (CoRecThere cr) (r :& rs) = r :& replace cr rs++modify :: CoRec (Compose Endo f) rs -> Rec f rs -> Rec f rs+modify (CoRecHere (Compose (Endo g))) (r :& rs) = g r :& rs+modify (CoRecThere cr) (r :& rs) = r :& modify cr rs++modify' :: CoRec Endo rs -> Rec Identity rs -> Rec Identity rs+modify' (CoRecHere (Endo g)) (Identity r :& rs) = Identity (g r) :& rs+modify' (CoRecThere cr) (r :& rs) = r :& modify' cr rs++-- Requires that the list be infinite+fromInfiniteList :: Rec proxy rs -> [a] -> Rec (Constant a) rs+fromInfiniteList RNil _ = RNil+fromInfiniteList (_ :& rs) (x : xs) = Constant x :& fromInfiniteList rs xs++fromList :: Rec proxy rs -> [a] -> Maybe (Rec (Constant a) rs)+fromList RNil _ = Just RNil+fromList (_ :& rs) (x : xs) = case fromList rs xs of+  Nothing -> Nothing+  Just rxs -> Just (Constant x :& rxs)++toList :: Rec (Constant a) rs -> [a]+toList RNil = []+toList (Constant a :& rs) = a : toList rs++zip :: Rec f rs -> Rec g rs -> Rec (Product f g) rs+zip RNil RNil           = RNil+zip (a :& as) (b :& bs) = Pair a b :& zip as bs++unzip :: Rec (Product f g) rs -> (Rec f rs, Rec g rs)+unzip (Pair a b :& rs) = (a :& as, b :& bs)+  where (as, bs) = unzip rs++zip2 :: Rec f rs -> Rec g rs -> Rec (FunctorRec '[f,g]) rs+zip2 RNil RNil = RNil+zip2 (a :& as) (b :& bs) =+  FunctorRec (Flap a :& Flap b :& RNil) :& zip2 as bs++zip3 :: Rec f rs -> Rec g rs -> Rec h rs -> Rec (FunctorRec '[f,g,h]) rs+zip3 RNil RNil RNil = RNil+zip3 (a :& as) (b :& bs) (c :& cs) =+  FunctorRec (Flap a :& Flap b :& Flap c :& RNil) :& zip3 as bs cs++zip4 :: Rec f rs -> Rec g rs -> Rec h rs -> Rec k rs -> Rec (FunctorRec '[f,g,h,k]) rs+zip4 RNil RNil RNil RNil = RNil+zip4 (a :& as) (b :& bs) (c :& cs) (d :& ds) =+  FunctorRec (Flap a :& Flap b :& Flap c :& Flap d :& RNil) :& zip4 as bs cs ds++just :: Rec f rs -> Rec (Compose Maybe f) rs+just = map (Compose . Just)++right :: Rec f rs -> Rec (Compose (Either a) f) rs+right = map (Compose . Right)++map :: (forall x. f x -> g x) -> Rec f rs -> Rec g rs+map = rmap++fromMaybe :: Rec f rs -> Rec (Compose Maybe f) rs -> Rec f rs+fromMaybe RNil RNil = RNil+fromMaybe (r :& rs) (Compose m :& ms) = case m of+  Nothing -> r :& fromMaybe rs ms+  Just s  -> s :& fromMaybe rs ms++fromMaybe' :: Rec Identity rs -> Rec Maybe rs -> Rec Identity rs+fromMaybe' RNil RNil = RNil+fromMaybe' (r :& rs) (m :& ms) = case m of+  Nothing -> r :& fromMaybe' rs ms+  Just s  -> Identity s :& fromMaybe' rs ms+
+ src/Data/Vinyl/Types.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}++module Data.Vinyl.Types +  ( Rec(..)+  , CoRec(..)+  , Flap(..)+  , FunctorRec(..)+  , FunctorCoRec(..)+  ) where++import           Data.Functor.Classes+import           Data.Vinyl.Core+import           Data.Functor.Contravariant+import           Data.Vinyl.Plus.TypeLevel+import           Data.Vinyl.TypeLevel++newtype Flap a f = Flap { getFlap :: f a }+  deriving Show++-- | 'CoRec' is a generalized coproduct. The value it holds+--   is the interpretation function @f@ applied to exactly one+--   of the types in the list. While a 'Rec' can be thought of+--   a nesting of tuples, a 'CoRec' can be thought of as a+--   nesting of 'Either's.+data CoRec :: (u -> *) -> [u] -> * where+  CoRecHere  :: !(f r) -> CoRec f (r ': rs)+  CoRecThere :: !(CoRec f rs) -> CoRec f (r ': rs)++-- For monoid, the item on top is mempty. Doing the+-- bottom one would require RecApplicative.+instance (Monoid (f r)) => Monoid (CoRec f '[r]) where+  mempty = CoRecHere mempty+  mappend (CoRecHere a) (CoRecHere b) = CoRecHere (mappend a b)++instance (Monoid (CoRec f (s ' : rs)), Monoid (f r)) => Monoid (CoRec f (r ': s ': rs)) where+  mempty = CoRecHere mempty+  mappend a b = case a of+    CoRecHere aVal -> case b of+      CoRecHere bVal -> CoRecHere (mappend aVal bVal)+      CoRecThere bCr -> CoRecThere bCr+    CoRecThere aCr -> case b of+      CoRecHere _ -> CoRecThere aCr+      CoRecThere bCr -> CoRecThere (mappend aCr bCr)++instance (Show (f r)) => Show (CoRec f '[r]) where+  show (CoRecHere a) = "CoRecHere (" ++ show a ++ ")"+instance (Show (CoRec f (s ': rs)), Show (f r)) => Show (CoRec f (r ': s ': rs)) where+  show (CoRecHere a) = "CoRecHere (" ++ show a ++ ")"+  show (CoRecThere cr) = "CoRecThere (" ++ show cr ++ ")"++newtype FunctorRec fs a = FunctorRec { getFunctorRec :: Rec (Flap a) fs }+  deriving (Show)+newtype FunctorCoRec fs a = FunctorCoRec { getFunctorCoRec :: CoRec (Flap a) fs }++deriving instance (Show (f r)) => Show (FunctorCoRec '[f] r)+deriving instance (Show (CoRec (Flap r) (g ': hs)), Show (f r)) => Show (FunctorCoRec (f ': g ': hs) r)++instance Functor (FunctorRec '[]) where+  fmap _ (FunctorRec RNil) = FunctorRec RNil++instance (Functor r, Functor (FunctorRec rs)) => Functor (FunctorRec (r ': rs)) where+  fmap f (FunctorRec (Flap r :& rs)) =+    FunctorRec (Flap (fmap f r) :& getFunctorRec (fmap f (FunctorRec rs)))++instance Applicative (FunctorRec '[]) where+  pure _ = FunctorRec RNil+  FunctorRec RNil <*> FunctorRec RNil = FunctorRec RNil++instance (Applicative r, Applicative (FunctorRec rs)) => Applicative (FunctorRec (r ': rs)) where+  pure a = FunctorRec (Flap (pure a) :& getFunctorRec (pure a))+  FunctorRec (Flap f :& fs) <*> FunctorRec (Flap a :& as) =+    FunctorRec (Flap (f <*> a) :& getFunctorRec (FunctorRec fs <*> FunctorRec as))++instance Contravariant (FunctorRec '[]) where+  contramap _ (FunctorRec RNil) = FunctorRec RNil++instance (Contravariant r, Contravariant (FunctorRec rs)) => Contravariant (FunctorRec (r ': rs)) where+  contramap f (FunctorRec (Flap r :& rs)) =+    FunctorRec (Flap (contramap f r) :& getFunctorRec (contramap f (FunctorRec rs)))++instance Functor r => Functor (FunctorCoRec '[r]) where+  fmap f (FunctorCoRec (CoRecHere (Flap a))) =+    FunctorCoRec (CoRecHere (Flap (fmap f a)))++instance (Functor f, Functor (FunctorCoRec (g ': fs))) => Functor (FunctorCoRec (f ': g ': fs)) where+  fmap f (FunctorCoRec cr) = FunctorCoRec $ case cr of+    CoRecHere (Flap v) -> CoRecHere (Flap (fmap f v))+    CoRecThere cr -> CoRecThere (getFunctorCoRec (fmap f (FunctorCoRec cr)))++instance Contravariant r => Contravariant (FunctorCoRec '[r]) where+  contramap f (FunctorCoRec (CoRecHere (Flap a))) =+    FunctorCoRec (CoRecHere (Flap (contramap f a)))++instance (Contravariant f, Contravariant (FunctorCoRec (g ': fs))) => Contravariant (FunctorCoRec (f ': g ': fs)) where+  contramap f (FunctorCoRec cr) = FunctorCoRec $ case cr of+    CoRecHere (Flap v) -> CoRecHere (Flap (contramap f v))+    CoRecThere cr -> CoRecThere (getFunctorCoRec (contramap f (FunctorCoRec cr)))
+ test/doctest.hs view
@@ -0,0 +1,16 @@+import           Test.DocTest (doctest)++main :: IO ()+main = doctest+  [ "-XDataKinds"+  , "-XMagicHash"+  , "-XRankNTypes"+  , "-XPolyKinds"+  , "-XKindSignatures"+  , "-XScopedTypeVariables"+  , "-XTypeOperators"+  , "-XTypeFamilies"+  , "src/Data/Vinyl/Prelude/CoRec.hs"+  , "src/Data/Vinyl/Tagged.hs"+  , "src/Data.Vinyl.Optic.Plain.Class.Tagged.Proxy.Identity.hs"+  ]
+ vinyl-plus.cabal view
@@ -0,0 +1,65 @@+name:                vinyl-plus+version:             0.1.0.0+synopsis:            Vinyl records utilities+description:         Please see README.md+homepage:            http://github.com/andrew/vinyl-plus+license:             BSD3+license-file:        LICENSE+author:              Andrew Martin+maintainer:          andrew.thaddeus@gmail.com+copyright:           2016 Andrew Martin+category:            Web+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     +      Data.Vinyl.Types+    , Data.Vinyl.Optic.Plain.Class+    , Data.Vinyl.Prelude.Rec+    , Data.Vinyl.Prelude.CoRec+    , Data.Vinyl.Plus.Functor.Prelude+    , Data.Vinyl.Optic.Tagged.Class+    , Data.Vinyl.Optic.Tagged.Proxy.Functor+    , Data.Vinyl.Optic.Tagged.Proxy.Identity+    , Data.Vinyl.Plus.TypeLevel+    , Data.Vinyl.Plus.Internal+    , Data.Tuple.TypeLevel+    , Data.Tagged.Functor+    , Data.TypeMap+  build-depends:       +      base >= 4.7 && < 5+    , vinyl+    , transformers+    , contravariant+    , unordered-containers+    , ghc-prim+    , profunctors+  default-language:    Haskell2010+  default-extensions:+    MagicHash+    PolyKinds+    RankNTypes+    TypeOperators+    DataKinds+    GADTs+    MultiParamTypeClasses+    TypeFamilies+    StandaloneDeriving+    ConstraintKinds+    ScopedTypeVariables+    BangPatterns++test-suite doctests+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          doctest.hs+  build-depends:    base >= 4.7 && <= 5, vinyl >= 0.5, doctest >= 0.8+  default-language: Haskell2010++source-repository head+  type:     git+  location: https://github.com/andrewthad/vinyl-plus+