summer 0.3.4.0 → 0.3.5.0

raw patch · 4 files changed

+63/−10 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• src/Data/Prodder.hs +24/−2
• src/Data/Summer.hs +26/−1
• summer.cabal +1/−1
• test/Test.hs +12/−6

@@ -66,7 +66,6 @@   , Selection(select)   , type FieldsFromSelector   , type Selector-    -- * Efficiently building 'Prod's   ) where  import Data.ForAll (type ForAll)@@ -91,6 +90,7 @@ atType :: forall a b xs f. (a `HasIndexIn` xs, Functor f) => (a -> f b) -> Prod xs -> f (Prod (Replace a b xs)) atType f (UnsafeProd v) = fmap (\b -> UnsafeProd $ v V.// [(fromIntegral i, unsafeCoerce b)]) (f (unsafeCoerce (v V.! fromIntegral i))) where   i = index @a @xs+{-# INLINE CONLIKE atType #-}  -- | A type for constructing products with linear memory use. newtype ProdBuilder (xs :: [*]) = UnsafeProdBuilder { unProdBuilder :: forall s. STRef s Int -> V.MVector s Any -> ST s () }@@ -99,10 +99,12 @@ consB :: x -> ProdBuilder xs -> ProdBuilder (x ': xs) consB x (UnsafeProdBuilder b) = UnsafeProdBuilder \ref v -> withIncrement ref \i -> do   MV.write v i (unsafeCoerce x)+{-# INLINE CONLIKE consB #-}  -- | Empty 'ProdBuilder'. emptyB :: ProdBuilder '[] emptyB = UnsafeProdBuilder \_ _ -> pure ()+{-# INLINE CONLIKE emptyB #-}  -- | Execute a 'ProdBuilder', pulling out a 'Prod'. buildProd :: forall xs. (KnownNat (Length xs)) => ProdBuilder xs -> Prod xs@@ -111,12 +113,14 @@   x <- MV.new (fromInteger $ natVal (Proxy @(Length xs)))   bs ref x   pure x+{-# INLINE CONLIKE buildProd #-}  -- | Appends two 'ProdBuilder's. appendB :: ProdBuilder xs -> ProdBuilder ys -> ProdBuilder (xs <> ys) appendB (UnsafeProdBuilder b) (UnsafeProdBuilder b') = UnsafeProdBuilder \ref v -> do   b ref v   b' ref v+{-# INLINE CONLIKE appendB #-}  -- | Creates a 'ProdBuilder' with a single element. singletonB :: x -> ProdBuilder '[x]@@ -182,6 +186,7 @@ -- inference and less piping around of constraints. dropFirst :: forall x xs. Prod (x ': xs) -> Prod xs dropFirst (UnsafeProd v) = UnsafeProd $ V.slice 1 (V.length v - 1) v+{-# INLINE CONLIKE dropFirst #-}  type family (<>) (xs :: [k]) (ys :: [k]) :: [k] where   '[] <> ys = ys@@ -216,9 +221,11 @@  produce :: (KnownNat (Length xs), Consume xs) => (forall r. Consumer xs r -> r) -> Prod xs produce f = buildProd $ produceB f+{-# INLINE CONLIKE produce #-}  empty :: Prod '[] empty = buildProd $ produceB id+{-# INLINE CONLIKE empty #-}  instance Consume '[] where   consume = flip const@@ -236,6 +243,7 @@   x <- f i   writeSTRef ref (i + 1)   pure x+{-# INLINE CONLIKE withIncrement #-}  instance Consume xs => Consume (x ': xs) where   consume (UnsafeProd v) g = consume @xs (UnsafeProd (V.tail v)) $ g (unsafeCoerce $ v V.! 0)@@ -302,13 +310,27 @@  instance FoldProd c '[] where   foldProd _f _p = mempty+  {-# INLINE CONLIKE foldProd #-}  instance (c x, FoldProd c xs) => FoldProd c (x ': xs) where   foldProd f p = f x <> foldProd @c f (dropFirst p) where     x = extract @x p+  {-# INLINE CONLIKE foldProd #-}  toList :: forall c xs a. FoldProd c xs => (forall x. c x => x -> a) -> Prod xs -> [a] toList f = foldProd @c (pure . f)+{-# INLINE CONLIKE toList #-}  class x `Contains` y where-  eject :: x -> y+  uncontain :: x -> y++instance {-# OVERLAPPABLE #-} x `HasIndexIn` xs => Prod xs `Contains` x where+  uncontain = extract++instance {-# OVERLAPPABLE #-} (KnownNat (Length xs'), Strengthen xs xs') => Prod xs `Contains` Prod xs' where+  uncontain = strengthen++newtype Nested a = Nested { unNest :: a }++instance {-# OVERLAPPABLE #-} (x `Contains` y, x `HasIndexIn` xs) => Prod xs `Contains` Nested y where+  uncontain = Nested . uncontain @x @y . uncontain @(Prod xs) @x

@@ -37,6 +37,7 @@   , consider   , considerFirst   , variant+  , UnorderedMatch(unorderedMatch)   , Match(match, override, unmatch)   , Unmatch   -- * Type families@@ -72,6 +73,11 @@ -- types in the given type list. data Sum (xs :: [*]) = UnsafeInj {-# UNPACK #-} !Word Any +-- | Deconstruct a 'Sum' with only one variant+eject :: Sum '[x] -> x+eject (UnsafeInj _ x) = unsafeCoerce x+{-# INLINE CONLIKE eject #-}+ -- | A prism which operates on a chosen variant of a 'Sum' variant :: forall a b xs p f. (a `HasTagIn` xs, Applicative f, Choice p) => p a (f b) -> p (Sum xs) (f (Sum (Replace a b xs))) variant p = dimap try replace (left' p) where@@ -81,6 +87,7 @@   replace = \case     Left fb -> fmap (UnsafeInj (tag @a @xs) . unsafeCoerce) fb     Right s -> pure s+{-# INLINE CONLIKE variant #-}  -- | Type family for replacing one type in a type level list with another type family Replace x y xs where@@ -189,11 +196,12 @@ unsafeForget (UnsafeInj tag' x) = if tag' < tag @x @xs then UnsafeInj tag' x                              else if tag' == tag @x @xs then error "unsafeForget: you can't forget the truth"                              else UnsafeInj (tag' - 1) x+{-# INLINE CONLIKE unsafeForget #-}   unsafeForgetFirst :: Sum (x ': xs) -> Sum xs unsafeForgetFirst (UnsafeInj tag' x) = UnsafeInj (tag' - 1) x-{-# INLINE CONLIKE unsafeForget #-}+{-# INLINE CONLIKE unsafeForgetFirst #-}  -- | Testing extensible sums for equality. instance (Eq (Sum xs), Eq x) => Eq (Sum (x ': xs)) where@@ -206,6 +214,7 @@   {-# INLINE CONLIKE (==) #-} instance Eq (Sum '[]) where   (==) = error "(==) base case: impossible by construction"+  {-# INLINE CONLIKE (==) #-}  -- | Transforming one sum into a sum which contains all of the same types class Weaken xs ys where@@ -220,6 +229,20 @@   weaken = error "weaken base case: impossible by construction"   {-# INLINE CONLIKE weaken #-} +class UnorderedMatch xs ys where+  unorderedMatch :: Sum xs -> Matcher ys r++instance UnorderedMatch '[] '[] where+  unorderedMatch = error "unordered match base case: impossible by construction"++instance (Match ys, y `HasTagIn` xs, UnorderedMatch (Delete y xs) ys) => UnorderedMatch xs (y ': ys) where+  unorderedMatch :: forall r. Sum xs -> (y -> r) -> Matcher ys r+  unorderedMatch uv@(UnsafeInj tag' x) f =+    if tag' == tag @y @xs+      then override @ys @r (f (unsafeCoerce x)) $ unorderedMatch @(Delete y xs) @ys @r (unsafeForget @y uv)+      else unorderedMatch @(Delete y xs) @ys @r (unsafeForget @y uv)+  + -- | The scott encoding of an extensible sum type family Matcher xs r :: Type where   Matcher '[] r = r@@ -267,8 +290,10 @@  instance ApplyFunction c '[] where   apply _f x = error "Impossible: empty sum"+  {-# INLINE CONLIKE apply #-}  instance (c x, ApplyFunction c xs) => ApplyFunction c (x ': xs) where   apply f x = case considerFirst x of     Right x' -> f x'     Left xs -> apply @c f xs+  {-# INLINE CONLIKE apply #-}

@@ -1,6 +1,6 @@ cabal-version:       2.4 name:                summer-version:             0.3.4.0+version:             0.3.5.0 synopsis:            An implementation of extensible products and sums description:         An implementation of extensible products and sums. license:             MIT

@@ -15,6 +15,9 @@ require :: Bool -> String -> IO () require p s = unless p $ fail s +requires' :: String -> [Bool] -> IO ()+requires' msg = mapM_ (\(i, b) -> require b (msg <> " " <> show i)) . zip [1..]+ requires :: [(Bool, String)] -> IO () requires = mapM_ (uncurry require) @@ -34,17 +37,17 @@     indexTest = do       let index' = index @Int @'[Bool, Int]           index'' = index @Bool @'[Bool, Int]-      requires-        [ (index' == 1, "Index " <> show index' <> " does not equal 1")-        , (index'' == 0, "Index " <> show index'' <> " does not equal 0")+      requires' "index"+        [ index' == 1+        , index'' == 0         ]     remapTest = do       let x :: Prod '[Int, Bool] = produce (\f -> f 10 True)       let y = remap ((+ 10000000000000000000000000000) . toInteger @Int) x       let z = remap not x-      requires-        [ (y == produce (\f -> f 10000000000000000000000000010 True), "Remapping does not work 1")-        , (z == produce (\f -> f 10 False), "Remapping does not work 2")+      requires' "remap"+        [ y == produce (\f -> f 10000000000000000000000000010 True)+        , z == produce (\f -> f 10 False)         ]     consumeAndProduceTest = do       let x :: Prod '[Int, Bool] = produce (\f -> f 10 True)@@ -181,3 +184,6 @@     applyTest = do       let x :: Sum '[Int, Bool] = Inj False       require (apply @Show show x == "False") "apply does not work 0"+    unorderedMatchTest = do+      let x :: Sum '[Int, Bool] = Inj False+      require (unorderedMatch @_ @'[Bool, Int] x not (== 10)) "unordered match does not work 0"