Skip to content

Commit e97e158

Browse files
recursion-ninjarecursion-ninja
committed
Adding some MonoAdjustable instances.
1 parent 615bd02 commit e97e158

File tree

1 file changed

+346
-0
lines changed

1 file changed

+346
-0
lines changed

‎src/Data/MonoTraversable/Keys.hs

Lines changed: 346 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -94,7 +94,9 @@ import Data.Vector (Vector)
9494
import qualified Data.Vector as V
9595
import Data.Vector.Instances ()
9696
import qualified Data.Vector.Storable as VS
97+
import qualified Data.Vector.Storable.Mutable as VSM
9798
import qualified Data.Vector.Unboxed as VU
99+
import qualified Data.Vector.Unboxed.Mutable as VUM
98100
import Data.Void
99101
import GHC.Generics
100102
import Prelude hiding (lookup)
@@ -258,6 +260,9 @@ class MonoFunctor mono => MonoAdjustable mono where
258260
{-# MINIMAL oadjust #-}
259261

260262
oadjust :: (Element mono -> Element mono) -> MonoKey mono -> mono -> mono
263+
default oadjust :: (Adjustable f, Element (f a) ~ a, MonoKey (f a) ~ Key f, f a ~ mono)
264+
=> (Element mono -> Element mono) -> MonoKey mono -> mono -> mono
265+
oadjust = adjust
261266

262267
oreplace :: MonoKey mono -> Element mono -> mono -> mono
263268
oreplace k v = oadjust (const v) k
@@ -1737,6 +1742,347 @@ instance MonoIndexable (ZipList a) where
17371742
oindex = index
17381743

17391744

1745+
-- * MonoAdjustable Instances
1746+
1747+
1748+
-- |
1749+
-- /Since @v0.1.0@/
1750+
instance MonoAdjustable (r -> a) where
1751+
{-# INLINE oadjust #-}
1752+
1753+
oadjust f _ g = f . g
1754+
1755+
1756+
-- |
1757+
-- /Since @v0.1.0@/
1758+
instance MonoAdjustable [a]
1759+
1760+
1761+
-- |
1762+
-- /Since @v0.1.0@/
1763+
instance MonoAdjustable (a, b) where
1764+
{-# INLINE oadjust #-}
1765+
1766+
oadjust f = const $ fmap f
1767+
1768+
1769+
-- |
1770+
-- /Since @v0.1.0@/
1771+
instance MonoAdjustable (Arg a b) where
1772+
{-# INLINE oadjust #-}
1773+
1774+
oadjust f = const $ fmap f
1775+
1776+
1777+
-- |
1778+
-- /Since @v0.1.0@/
1779+
instance MonoAdjustable BS.ByteString where
1780+
{-# INLINE oadjust #-}
1781+
1782+
oadjust f i bs
1783+
| i < 0
1784+
|| i >= BS.length bs = bs
1785+
| otherwise = snd $ BS.mapAccumL g 0 bs
1786+
where
1787+
g k v = (succ k, if k == i then f v else v)
1788+
1789+
1790+
-- |
1791+
-- /Since @v0.1.0@/
1792+
instance MonoAdjustable BSL.ByteString where
1793+
{-# INLINE oadjust #-}
1794+
1795+
oadjust f i bs
1796+
| i < 0
1797+
|| i >= fromEnum (BSL.length bs) = bs
1798+
| otherwise = snd $ BSL.mapAccumL g 0 bs
1799+
where
1800+
g k v = (succ k, if k == i then f v else v)
1801+
1802+
1803+
-- |
1804+
-- /Since @v0.1.0@/
1805+
instance MonoAdjustable (Const m a) where
1806+
{-# INLINE oadjust #-}
1807+
1808+
oadjust = const $ const id
1809+
1810+
1811+
-- |
1812+
-- /Since @v0.1.0@/
1813+
instance Functor m => MonoAdjustable (ContT r m a) where
1814+
{-# INLINE oadjust #-}
1815+
1816+
oadjust f = const $ fmap f
1817+
1818+
1819+
-- |
1820+
-- /Since @v0.1.0@/
1821+
instance MonoAdjustable (Either a b) where
1822+
{-# INLINE oadjust #-}
1823+
1824+
oadjust f = const $ fmap f
1825+
1826+
1827+
-- |
1828+
-- /Since @v0.1.0@/
1829+
instance (Eq k, Hashable k) => MonoAdjustable (HashMap k v) where
1830+
{-# INLINE oadjust #-}
1831+
1832+
oadjust = HM.adjust
1833+
1834+
1835+
-- Cannot instantiate because the adjust might violate the internal structure
1836+
-- instance MonoAdjustable (HashSet v)
1837+
1838+
1839+
-- |
1840+
-- /Since @v0.1.0@/
1841+
instance MonoAdjustable (Identity a)
1842+
1843+
1844+
-- |
1845+
-- /Since @v0.1.0@/
1846+
instance Functor m => MonoAdjustable (IdentityT m a) where
1847+
{-# INLINE oadjust #-}
1848+
1849+
oadjust f = const $ fmap f
1850+
1851+
1852+
-- |
1853+
-- /Since @v0.1.0@/
1854+
instance MonoAdjustable (IntMap a) where
1855+
{-# INLINE oadjust #-}
1856+
1857+
oadjust = IM.adjust
1858+
1859+
1860+
-- Cannot instantiate because the adjust might violate the internal structure
1861+
-- instance MonoAdjustable IntSet
1862+
1863+
1864+
-- |
1865+
-- /Since @v0.1.0@/
1866+
instance MonoAdjustable (IO a) where
1867+
{-# INLINE oadjust #-}
1868+
1869+
oadjust f = const $ fmap f
1870+
1871+
1872+
-- |
1873+
-- /Since @v0.1.0@/
1874+
instance Functor m => MonoAdjustable (ListT m a) where
1875+
{-# INLINE oadjust #-}
1876+
1877+
oadjust f i = ListT . fmap (adjust f i) . runListT
1878+
1879+
1880+
-- |
1881+
-- /Since @v0.1.0@/
1882+
instance Ord k => MonoAdjustable (Map k v) where
1883+
{-# INLINE oadjust #-}
1884+
1885+
oadjust = Map.adjust
1886+
1887+
1888+
-- |
1889+
-- /Since @v0.1.0@/
1890+
instance MonoAdjustable (Maybe a) where
1891+
{-# INLINE oadjust #-}
1892+
1893+
oadjust f = const $ fmap f
1894+
1895+
1896+
-- |
1897+
-- /Since @v0.1.0@/
1898+
instance Functor m => MonoAdjustable (MaybeT m a) where
1899+
{-# INLINE oadjust #-}
1900+
1901+
oadjust f = const $ fmap f
1902+
1903+
1904+
-- |
1905+
-- /Since @v0.1.0@/
1906+
instance MonoAdjustable (NonEmpty a) {-where
1907+
1908+
oadjust = adjust
1909+
-}
1910+
1911+
1912+
-- |
1913+
-- /Since @v0.1.0@/
1914+
instance MonoAdjustable (Option a) where
1915+
{-# INLINE oadjust #-}
1916+
1917+
oadjust f = const $ fmap f
1918+
1919+
1920+
-- |
1921+
-- /Since @v0.1.0@/
1922+
instance ( Adjustable f
1923+
, Adjustable g
1924+
, MonoKey (f a) ~ Key f
1925+
, MonoKey (g a) ~ Key g
1926+
) => MonoAdjustable (Product f g a)
1927+
1928+
1929+
-- |
1930+
-- /Since @v0.1.0@/
1931+
instance Functor m => MonoAdjustable (ReaderT r m a) where
1932+
{-# INLINE oadjust #-}
1933+
1934+
oadjust f = const $ fmap f
1935+
1936+
1937+
-- |
1938+
-- /Since @v0.1.0@/
1939+
instance Functor m => MonoAdjustable (RWST r w s m a) where
1940+
{-# INLINE oadjust #-}
1941+
1942+
oadjust f = const $ fmap f
1943+
1944+
1945+
-- |
1946+
-- /Since @v0.1.0@/
1947+
instance Functor m => MonoAdjustable (S.RWST r w s m a) where
1948+
{-# INLINE oadjust #-}
1949+
1950+
oadjust f = const $ fmap f
1951+
1952+
1953+
-- |
1954+
-- /Since @v0.1.0@/
1955+
instance MonoAdjustable (Seq a) where
1956+
{-# INLINE oadjust #-}
1957+
1958+
oadjust = Seq.adjust'
1959+
1960+
1961+
-- Cannot instantiate because the adjust might violate the internal structure
1962+
-- instance MonoAdjustable Set
1963+
1964+
1965+
-- |
1966+
-- /Since @v0.1.0@/
1967+
instance Functor m => MonoAdjustable (StateT s m a) where
1968+
{-# INLINE oadjust #-}
1969+
1970+
oadjust f = const $ fmap f
1971+
1972+
1973+
-- |
1974+
-- /Since @v0.1.0@/
1975+
instance Functor m => MonoAdjustable (S.StateT s m a) where
1976+
{-# INLINE oadjust #-}
1977+
1978+
oadjust f = const $ fmap f
1979+
1980+
1981+
-- |
1982+
-- /Since @v0.1.0@/
1983+
instance MonoAdjustable T.Text where
1984+
{-# INLINE oadjust #-}
1985+
1986+
oadjust f i ts
1987+
| i < 0
1988+
|| i >= T.length ts = ts
1989+
| otherwise = snd $ T.mapAccumL g 0 ts
1990+
where
1991+
g k v = (succ k, if k == i then f v else v)
1992+
1993+
1994+
-- |
1995+
-- /Since @v0.1.0@/
1996+
instance MonoAdjustable TL.Text where
1997+
{-# INLINE oadjust #-}
1998+
1999+
oadjust f i ts
2000+
| i < 0
2001+
|| i >= fromEnum (TL.length ts) = ts
2002+
| otherwise = snd $ TL.mapAccumL g 0 ts
2003+
where
2004+
g k v = (succ k, if k == i then f v else v)
2005+
2006+
2007+
-- |
2008+
-- /Since @v0.1.0@/
2009+
instance MonoAdjustable (Tree a)
2010+
2011+
2012+
-- |
2013+
-- /Since @v0.1.0@/
2014+
instance MonoAdjustable (Vector a)
2015+
2016+
2017+
-- |
2018+
-- /Since @v0.1.0@/
2019+
instance VU.Unbox a => MonoAdjustable (VU.Vector a) where
2020+
{-# INLINE oadjust #-}
2021+
2022+
oadjust f i = VU.modify $ \v -> VUM.modify v f i
2023+
2024+
2025+
-- |
2026+
-- /Since @v0.1.0@/
2027+
instance VS.Storable a => MonoAdjustable (VS.Vector a) where
2028+
{-# INLINE oadjust #-}
2029+
2030+
oadjust f i = VS.modify $ \v -> VSM.modify v f i
2031+
2032+
2033+
-- |
2034+
-- /Since @v0.1.0@/
2035+
instance MonoAdjustable (ViewL a) where
2036+
{-# INLINE oadjust #-}
2037+
2038+
oadjust f = const $ fmap f
2039+
2040+
2041+
-- |
2042+
-- /Since @v0.1.0@/
2043+
instance MonoAdjustable (ViewR a) where
2044+
{-# INLINE oadjust #-}
2045+
2046+
oadjust f = const $ fmap f
2047+
2048+
2049+
-- |
2050+
-- /Since @v0.1.0@/
2051+
instance Arrow a => MonoAdjustable (WrappedArrow a b c) where
2052+
{-# INLINE oadjust #-}
2053+
2054+
oadjust f = const $ fmap f
2055+
2056+
2057+
-- |
2058+
-- /Since @v0.1.0@/
2059+
instance Monad m => MonoAdjustable (WrappedMonad m a) where
2060+
{-# INLINE oadjust #-}
2061+
2062+
oadjust f = const $ fmap f
2063+
2064+
2065+
-- |
2066+
-- /Since @v0.1.0@/
2067+
instance Functor m => MonoAdjustable (WriterT w m a) where
2068+
{-# INLINE oadjust #-}
2069+
2070+
oadjust f = const $ fmap f
2071+
2072+
2073+
-- |
2074+
-- /Since @v0.1.0@/
2075+
instance Functor m => MonoAdjustable (S.WriterT w m a) where
2076+
{-# INLINE oadjust #-}
2077+
2078+
oadjust f = const $ fmap f
2079+
2080+
2081+
-- |
2082+
-- /Since @v0.1.0@/
2083+
instance MonoAdjustable (ZipList a)
2084+
2085+
17402086
-- * Unwraping functions
17412087

17422088

0 commit comments

Comments
 (0)