extensible 0.2.1 → 0.2.2

raw patch · 9 files changed

+46/−7 lines, 9 filesdep +template-haskelldep −ghc-primdep ~base

Dependencies added: template-haskell

Dependencies removed: ghc-prim

Dependency ranges changed: base

Files

• extensible.cabal +3/−3
• src/Data/Extensible.hs +1/−0
• src/Data/Extensible/Inclusion.hs +2/−0
• src/Data/Extensible/Internal.hs +19/−0
• src/Data/Extensible/League.hs +1/−0
• src/Data/Extensible/Plain.hs +18/−0
• src/Data/Extensible/Product.hs +0/−4
• src/Data/Extensible/Sum.hs +1/−0
• src/Data/Extensible/Union.hs +1/−0

@@ -1,5 +1,5 @@ name:                extensible-version:             0.2.1+version:             0.2.2 synopsis:            Poly-kinded, extensible ADTs homepage:            https://github.com/fumieval/extensible description:         Extensible Products/Unions@@ -11,7 +11,7 @@ category:            Data build-type:          Simple extra-source-files:-    .gitignore+  .gitignore cabal-version:       >=1.10  source-repository head@@ -30,7 +30,7 @@     Data.Extensible.Sum     Data.Extensible.Union   default-extensions: TypeOperators, DeriveDataTypeable-  build-depends:       base == 4.*, ghc-prim+  build-depends:       base >= 4.7 && <5, template-haskell   hs-source-dirs:      src   ghc-options: -Wall   default-language:    Haskell2010

@@ -33,6 +33,7 @@   , runPosition   , (∈)()   , Member(..)+  , ord   ) where import Data.Extensible.Internal import Data.Extensible.Inclusion

@@ -30,7 +30,9 @@ -- | /O(m log n)/ Select some elements. shrink :: (xs ⊆ ys) => h :* ys -> h :* xs shrink h = hmap (\pos -> hlookup pos h) inclusion+{-# INLINE shrink #-}  -- | /O(log n)/ Embed to a larger union. spread :: (xs ⊆ ys) => h :| xs -> h :| ys spread (UnionAt pos h) = UnionAt (hlookup pos inclusion) h+{-# INLINE spread #-}

@@ -2,9 +2,11 @@ {-# LANGUAGE GADTs, TypeFamilies, TypeOperators #-} {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} module Data.Extensible.Internal (Position   , runPosition   , comparePosition+  , ord   , Nav(..)   , navigate   , here@@ -22,9 +24,21 @@ import Data.Type.Equality import Data.Proxy import Control.Applicative+import Control.Monad import Unsafe.Coerce import Data.Typeable+import Language.Haskell.TH +ord :: Int -> Q Exp+ord n = do+  let names = map mkName $ take (n + 1) $ concatMap (flip replicateM ['a'..'z']) [1..]+  let rest = mkName "any"+  let cons x xs = PromotedConsT `AppT` x `AppT` xs+  let t = foldr cons (VarT rest) (map VarT names)+  sigE (conE 'Position `appE` litE (IntegerL $ toInteger n))+    $ forallT (PlainTV rest : map PlainTV names) (pure [])+    $ conT ''Position `appT` pure t `appT` varT (names !! n)+ -- | The position of @x@ in the type level set @xs@. newtype Position (xs :: [k]) (x :: k) = Position Int deriving (Show, Eq, Ord, Typeable) @@ -38,6 +52,7 @@ comparePosition (Position m) (Position n)   | m == n = Just (unsafeCoerce Refl)   | otherwise = Nothing+{-# INLINE comparePosition #-}  navigate :: Position xs x -> Nav xs x navigate (Position 0) = unsafeCoerce Here@@ -52,12 +67,15 @@  here :: Position (x ': xs) x here = Position 0+{-# INLINE here #-}  navL :: Position (Half xs) y -> Position (x ': xs) y navL (Position x) = Position (x * 2 + 1)+{-# INLINE navL #-}  navR :: Position (Half (Tail xs)) y -> Position (x ': xs) y navR (Position x) = Position ((x + 1) * 2)+{-# INLINE navR #-}  -- | Unicode flipped alias for 'Member' type x ∈ xs = Member xs x@@ -118,3 +136,4 @@ -- GHC can't prove this lemmaHalfTail :: Proxy xs -> p (x ': Half (Tail xs)) -> p (Half (x ': xs)) lemmaHalfTail _ = unsafeCoerce+{-# INLINE lemmaHalfTail #-}

@@ -48,4 +48,5 @@ -- | Prepend a clause for @'Match' ('Fuse' x)@ as well as ('<?!'). (<?~) :: (f x -> a) -> Match (Fuse x) a :* fs -> Match (Fuse x) a :* (f ': fs) (<?~) f = (<:*) (Match (f . meltdown))+{-# INLINE (<?~) #-} infixr 1 <?~

@@ -19,7 +19,10 @@   , bury   , (<%|)   , record+  , recordAt   , (<?%)+  , K1(..)+  , (<?!)   )where import Data.Extensible.Internal import Data.Extensible.Product@@ -56,10 +59,12 @@ -- | Extract a plain value. pluck :: (x ∈ xs) => AllOf xs -> x pluck = getK0 . hlookup membership+{-# INLINE pluck #-}  -- | Embed a plain value. bury :: (x ∈ xs) => x -> OneOf xs bury = embed . K0+{-# INLINE bury #-}  -- | Naive pattern matching for a plain value. (<%|) :: (x -> r) -> (OneOf xs -> r) -> OneOf (x ': xs) -> r@@ -70,8 +75,21 @@ record f = sector $ unsafeCoerce f `asTypeOf` (fmap K0 . f . getK0) {-# INLINE record #-} +-- | /O(log n)/ A lens for a plain value in a product.+recordAt :: (Functor f) => Position xs x -> (x -> f x) -> (AllOf xs -> f (AllOf xs))+recordAt pos f = sectorAt pos $ unsafeCoerce f `asTypeOf` (fmap K0 . f . getK0)+{-# INLINE recordAt #-}+ -- | Prepend a clause for a plain value. (<?%) :: (x -> a) -> Match K0 a :* xs -> Match K0 a :* (x ': xs) (<?%) = unsafeCoerce (<:*)+{-# INLINE (<?%) #-} infixr 1 <?% +-- | Wrap a type that has a kind @* -> *@.+newtype K1 a f = K1 { getK1 :: f a } deriving (Eq, Ord, Read, Typeable)++-- | Prepend a clause for a parameterized value.+(<?!) :: (f x -> a) -> Match (K1 x) a :* xs -> Match (K1 x) a :* (f ': fs)+(<?!) = unsafeCoerce (<:*)+infixr 1 <?!

@@ -160,11 +160,9 @@  instance Generate '[] where   generate _ = Nil-  {-# INLINE generate #-}  instance (Generate (Half xs), Generate (Half (Tail xs))) => Generate (x ': xs) where   generate f = Tree (f here) (generate (f . navL)) (generate (f . navR)) where-  {-# INLINE generate #-}  -- | Guarantees the all elements satisfies the predicate. class Forall c (xs :: [k]) where@@ -172,8 +170,6 @@  instance Forall c '[] where   generateFor _ _ = Nil-  {-# INLINE generateFor #-}  instance (c x, Forall c (Half xs), Forall c (Half (Tail xs))) => Forall c (x ': xs) where   generateFor proxy f = Tree (f here) (generateFor proxy (f . navL)) (generateFor proxy (f . navR)) where-  {-# INLINE generateFor #-}

@@ -67,3 +67,4 @@ picked f u@(UnionAt pos h) = case comparePosition (membership :: Position xs x) pos of   Just Refl -> fmap (UnionAt pos) (f h)   Nothing -> pure u+{-# INLINE picked #-}

@@ -49,4 +49,5 @@ -- | Prepend a clause for @'Match' ('Flux' x)@ as well as ('<?!'). (<$?~) :: (forall b. f b -> (b -> x) -> a) -> Match (Flux x) a :* fs -> Match (Flux x) a :* (f ': fs) (<$?~) f = (<:*) $ Match $ \(Flux g m) -> f m g+{-# INLINE (<$?~) #-} infixr 1 <$?~