summer 0.3.6.0 → 0.3.7.0

raw patch · 4 files changed

+40/−1 lines, 4 files

Files

src/Data/Prodder.hs +10/−0
src/Data/Summer.hs +15/−0
summer.cabal +1/−1
test/Test.hs +14/−0

src/Data/Prodder.hs view

@@ -82,9 +82,19 @@ import Data.Proxy (Proxy(Proxy)) import Control.Monad.ST import Data.STRef (newSTRef, STRef, writeSTRef, readSTRef)+import Data.Typeable (Typeable)+import Data.Monoid (Endo (Endo, appEndo))+import Data.List (intersperse)+import Data.Foldable (fold)  -- | An extensible product type newtype Prod (xs :: [*]) = UnsafeProd { unProd :: Vector Any }+  deriving (Typeable)++-- | Showing extensible products.+instance FoldProd Show xs => Show (Prod xs) where+  showsPrec d xs = showParen (d > 10) . appEndo . fold $+    [Endo $ \r -> "[" <> r] <> intersperse (Endo $ \r -> ", " <> r) (toList @Show (Endo . showsPrec (d + 1)) xs) <> [Endo $ \r -> "]" <> r]  -- | Lens to modify one element of a product. atType :: forall a b xs f. (a `HasIndexIn` xs, Functor f) => (a -> f b) -> Prod xs -> f (Prod (Replace a b xs))

src/Data/Summer.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE LambdaCase #-}@@ -67,11 +68,13 @@ import Generics.SOP (Generic(..)) import qualified Generics.SOP as SOP import Data.Profunctor (Profunctor(dimap), Choice(..))+import Data.Typeable (typeRep, Typeable) import Data.ForAll (type ForAll)  -- | The extensible sum type, allowing inhabitants to be of any of the -- types in the given type list. data Sum (xs :: [*]) = UnsafeInj {-# UNPACK #-} !Word Any+  deriving (Typeable)  -- | Deconstruct a 'Sum' with only one variant eject :: Sum '[x] -> x@@ -215,6 +218,18 @@ instance Eq (Sum '[]) where   (==) = error "(==) base case: impossible by construction"   {-# INLINE CONLIKE (==) #-}++-- | Showing extensible sums.+instance Show (Sum '[]) where+  showsPrec n uv = error "show base case: impossible by construction"+instance (Show x, Typeable x, Show (Sum xs)) => Show (Sum (x ': xs)) where+  showsPrec d uv@(UnsafeInj tag' x)+    | tag' == 0 = showParen (d > 10) $+          showString "Inj @"+        . showParen True (showsPrec (d + 1) (typeRep (Proxy @x)))+        . showString " "+        . showParen True (showsPrec @x (d + 1) (unsafeCoerce x))+    | otherwise = showsPrec @(Sum xs) d (unsafeForgetFirst uv)  -- | Transforming one sum into a sum which contains all of the same types class Weaken xs ys where

summer.cabal view

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

test/Test.hs view

@@ -30,6 +30,10 @@   , strengthenTest   , tailNTest   , initNTest+  , prodBuilderTest+  , selectTest+  , foldProdTest+  , showTest   ]   where     catchAndDisplay (x : xs) = catch @SomeException x print >> catchAndDisplay xs@@ -102,6 +106,10 @@         [ (toList @Show show x == [show "Hello", show True], "toList does not work 0")         , (toList @Eq (\a -> a == a) x == [True, True], "toList does not work 1")         ]+    showTest = do+      let x :: Prod '[Int, Bool, Char, Float] = produce (\f -> f 10 True 'a' 0.2)+      require (show x == "[10, True, 'a', 0.2]") "show product 0"+        sumTest :: IO () sumTest = catchAndDisplay@@ -114,6 +122,9 @@   , inmapTest   , smapTest   , unmatchTest+  , applyTest+  , unorderedMatchTest+  , showTest   ]   where     catchAndDisplay (x : xs) = catch @SomeException x print >> catchAndDisplay xs@@ -187,3 +198,6 @@     unorderedMatchTest = do       let x :: Sum '[Int, Bool] = Inj False       require (unorderedMatch x not (\(x :: Int) -> x == 10)) "unordered match does not work 0"+    showTest = do+      let x :: Sum '[Int, Bool] = Inj False+      require (show x == "Inj @Bool False") "show sum does not work 0"