diff options
Diffstat (limited to 'src/Data')
| -rw-r--r-- | src/Data/Array/Mixed.hs | 26 | ||||
| -rw-r--r-- | src/Data/Array/Nested/Internal.hs | 46 |
2 files changed, 60 insertions, 12 deletions
diff --git a/src/Data/Array/Mixed.hs b/src/Data/Array/Mixed.hs index 33d9f56..03b411c 100644 --- a/src/Data/Array/Mixed.hs +++ b/src/Data/Array/Mixed.hs @@ -97,11 +97,13 @@ type ListX :: [Maybe Nat] -> (Maybe Nat -> Type) -> Type data ListX sh f where ZX :: ListX '[] f (::%) :: f n -> ListX sh f -> ListX (n : sh) f -deriving instance (forall n. Show (f n)) => Show (ListX sh f) deriving instance (forall n. Eq (f n)) => Eq (ListX sh f) deriving instance (forall n. Ord (f n)) => Ord (ListX sh f) infixr 3 ::% +instance (forall n. Show (f n)) => Show (ListX sh f) where + showsPrec _ = showListX shows + data UnconsListXRes f sh1 = forall n sh. (n : sh ~ sh1) => UnconsListXRes (ListX sh f) (f n) unconsListX :: ListX sh1 f -> Maybe (UnconsListXRes f sh1) @@ -116,11 +118,18 @@ foldListX :: Monoid m => (forall n. f n -> m) -> ListX sh f -> m foldListX _ ZX = mempty foldListX f (x ::% xs) = f x <> foldListX f xs +showListX :: forall sh f. (forall n. f n -> ShowS) -> ListX sh f -> ShowS +showListX f l = go "[" l . showString "]" + where + go :: String -> ListX sh' f -> ShowS + go _ ZX = id + go prefix (x ::% xs) = showString prefix . f x . go "," xs + type role IxX nominal representational type IxX :: [Maybe Nat] -> Type -> Type newtype IxX sh i = IxX (ListX sh (Const i)) - deriving (Show, Eq, Ord) + deriving (Eq, Ord) pattern ZIX :: forall sh i. () => sh ~ '[] => IxX sh i pattern ZIX = IxX ZX @@ -137,6 +146,9 @@ infixr 3 :.% type IIxX sh = IxX sh Int +instance Show i => Show (IxX sh i) where + showsPrec _ (IxX l) = showListX (\(Const i) -> shows i) l + instance Functor (IxX sh) where fmap f (IxX l) = IxX (fmapListX (Const . f . getConst) l) @@ -161,7 +173,7 @@ fromSMayNat' = fromSMayNat id fromSNat' type role ShX nominal representational type ShX :: [Maybe Nat] -> Type -> Type newtype ShX sh i = ShX (ListX sh (SMayNat i SNat)) - deriving (Show, Eq, Ord) + deriving (Eq, Ord) pattern ZSX :: forall sh i. () => sh ~ '[] => ShX sh i pattern ZSX = ShX ZX @@ -178,6 +190,9 @@ infixr 3 :$% type IShX sh = ShX sh Int +instance Show i => Show (ShX sh i) where + showsPrec _ (ShX l) = showListX (fromSMayNat shows (shows . fromSNat)) l + instance Functor (ShX sh) where fmap f (ShX l) = ShX (fmapListX (fromSMayNat (SUnknown . f) SKnown) l) @@ -189,7 +204,7 @@ lengthShX (_ :$% sh) = 1 + lengthShX sh -- | The part of a shape that is statically known. type StaticShX :: [Maybe Nat] -> Type newtype StaticShX sh = StaticShX (ListX sh (SMayNat () SNat)) - deriving (Show, Eq, Ord) + deriving (Eq, Ord) pattern ZKX :: forall sh. () => sh ~ '[] => StaticShX sh pattern ZKX = StaticShX ZX @@ -204,6 +219,9 @@ infixr 3 :!% {-# COMPLETE ZKX, (:!%) #-} +instance Show (StaticShX sh) where + showsPrec _ (StaticShX l) = showListX (fromSMayNat shows (shows . fromSNat)) l + type family Rank sh where Rank '[] = 0 diff --git a/src/Data/Array/Nested/Internal.hs b/src/Data/Array/Nested/Internal.hs index cf90240..c66bd07 100644 --- a/src/Data/Array/Nested/Internal.hs +++ b/src/Data/Array/Nested/Internal.hs @@ -192,25 +192,34 @@ type ListR :: Nat -> Type -> Type data ListR n i where ZR :: ListR 0 i (:::) :: forall n {i}. i -> ListR n i -> ListR (n + 1) i -deriving instance Show i => Show (ListR n i) deriving instance Eq i => Eq (ListR n i) deriving instance Ord i => Ord (ListR n i) deriving instance Functor (ListR n) deriving instance Foldable (ListR n) infixr 3 ::: +instance Show i => Show (ListR n i) where + showsPrec _ = showListR shows + data UnconsListRRes i n1 = forall n. (n + 1 ~ n1) => UnconsListRRes (ListR n i) i unconsListR :: ListR n1 i -> Maybe (UnconsListRRes i n1) unconsListR (i ::: sh') = Just (UnconsListRRes sh' i) unconsListR ZR = Nothing +showListR :: forall sh i. (i -> ShowS) -> ListR sh i -> ShowS +showListR f l = go "[" l . showString "]" + where + go :: String -> ListR sh' i -> ShowS + go _ ZR = id + go prefix (x ::: xs) = showString prefix . f x . go "," xs + -- | An index into a rank-typed array. type role IxR nominal representational type IxR :: Nat -> Type -> Type newtype IxR n i = IxR (ListR n i) - deriving (Show, Eq, Ord) + deriving (Eq, Ord) deriving newtype (Functor, Foldable) pattern ZIR :: forall n i. () => n ~ 0 => IxR n i @@ -228,15 +237,16 @@ infixr 3 :.: type IIxR n = IxR n Int +instance Show i => Show (IxR n i) where + showsPrec _ (IxR l) = showListR shows l + type role ShR nominal representational type ShR :: Nat -> Type -> Type newtype ShR n i = ShR (ListR n i) - deriving (Show, Eq, Ord) + deriving (Eq, Ord) deriving newtype (Functor, Foldable) -type IShR n = ShR n Int - pattern ZSR :: forall n i. () => n ~ 0 => ShR n i pattern ZSR = ShR ZR @@ -250,17 +260,24 @@ infixr 3 :$: {-# COMPLETE ZSR, (:$:) #-} +type IShR n = ShR n Int + +instance Show i => Show (ShR n i) where + showsPrec _ (ShR l) = showListR shows l + type role ListS nominal representational type ListS :: [Nat] -> (Nat -> Type) -> Type data ListS sh f where ZS :: ListS '[] f (::$) :: forall n sh {f}. KnownNat n => f n -> ListS sh f -> ListS (n : sh) f -deriving instance (forall n. Show (f n)) => Show (ListS sh f) deriving instance (forall n. Eq (f n)) => Eq (ListS sh f) deriving instance (forall n. Ord (f n)) => Ord (ListS sh f) infixr 3 ::$ +instance (forall n. Show (f n)) => Show (ListS sh f) where + showsPrec _ = showListS shows + data UnconsListSRes f sh1 = forall n sh. (KnownNat n, n : sh ~ sh1) => UnconsListSRes (ListS sh f) (f n) unconsListS :: ListS sh1 f -> Maybe (UnconsListSRes f sh1) @@ -275,6 +292,13 @@ foldListS :: Monoid m => (forall n. f n -> m) -> ListS sh f -> m foldListS _ ZS = mempty foldListS f (x ::$ xs) = f x <> foldListS f xs +showListS :: forall sh f. (forall n. f n -> ShowS) -> ListS sh f -> ShowS +showListS f l = go "[" l . showString "]" + where + go :: String -> ListS sh' f -> ShowS + go _ ZS = id + go prefix (x ::$ xs) = showString prefix . f x . go "," xs + -- | An index into a shape-typed array. -- @@ -285,7 +309,7 @@ foldListS f (x ::$ xs) = f x <> foldListS f xs type role IxS nominal representational type IxS :: [Nat] -> Type -> Type newtype IxS sh i = IxS (ListS sh (Const i)) - deriving (Show, Eq, Ord) + deriving (Eq, Ord) pattern ZIS :: forall sh i. () => sh ~ '[] => IxS sh i pattern ZIS = IxS ZS @@ -302,6 +326,9 @@ infixr 3 :.$ type IIxS sh = IxS sh Int +instance Show i => Show (IxS sh i) where + showsPrec _ (IxS l) = showListS (\(Const i) -> shows i) l + instance Functor (IxS sh) where fmap f (IxS l) = IxS (fmapListS (Const . f . getConst) l) @@ -313,7 +340,7 @@ instance Foldable (IxS sh) where type role ShS nominal type ShS :: [Nat] -> Type newtype ShS sh = ShS (ListS sh SNat) - deriving (Show, Eq, Ord) + deriving (Eq, Ord) pattern ZSS :: forall sh. () => sh ~ '[] => ShS sh pattern ZSS = ShS ZS @@ -329,6 +356,9 @@ infixr 3 :$$ {-# COMPLETE ZSS, (:$$) #-} +instance Show (ShS sh) where + showsPrec _ (ShS l) = showListS (shows . fromSNat) l + -- | Wrapper type used as a tag to attach instances on. The instances on arrays -- of @'Primitive' a@ are more polymorphic than the direct instances for arrays |