MapWith 0.1.0.0 → 0.2.0.0
raw patch · 15 files changed
+1434/−168 lines, 15 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ CurryTF: ($#) :: CurryTF args r => FnType args r -> args -> r
+ CurryTF: --
+ CurryTF: -- >>> :kind! FnType (Char, (Int, (Bool, ()))) String
+ CurryTF: -- </pre>
+ CurryTF: -- <pre>
+ CurryTF: -- = Char -> Int -> Bool -> [Char]
+ CurryTF: -- FnType (Char, (Int, (Bool, ()))) String :: *
+ CurryTF: -- type <tt>r</tt>. For example:
+ CurryTF: -- types embedded in <tt>args</tt> applied and that returns a result of
+ CurryTF: -- | The type of the (curried) function that can have arguments of the
+ CurryTF: app1 :: a -> App1 a
+ CurryTF: app2 :: a -> b -> App2 a b
+ CurryTF: app3 :: a -> b -> c -> App3 a b c
+ CurryTF: app4 :: a -> b -> c -> d -> App4 a b c d
+ CurryTF: class CurryTF args r where {
+ CurryTF: curryN :: CurryTF args r => (args -> r) -> FnType args r
+ CurryTF: instance CurryTF.CurryTF () r
+ CurryTF: instance CurryTF.CurryTF moreArgs r => CurryTF.CurryTF (arg, moreArgs) r
+ CurryTF: type App1 a = (a, ())
+ CurryTF: type App2 a b = (a, (b, ()))
+ CurryTF: type App3 a b c = (a, (b, (c, ())))
+ CurryTF: type App4 a b c d = (a, (b, (c, (d, ()))))
+ CurryTF: type family FnType args r :: *;
+ CurryTF: uncurryN :: CurryTF args r => FnType args r -> args -> r
+ CurryTF: }
+ MapWith: adj2Elts :: Injector a (App2 (Maybe a) (Maybe a))
+ MapWith: app1 :: a -> App1 a
+ MapWith: app2 :: a -> b -> App2 a b
+ MapWith: app3 :: a -> b -> c -> App3 a b c
+ MapWith: app4 :: a -> b -> c -> d -> App4 a b c d
+ MapWith: evenElt :: Injector a (App1 Bool)
+ MapWith: foldl1Elts :: (a -> a -> a) -> Injector a (App1 a)
+ MapWith: foldlElts :: (i -> a -> i) -> i -> Injector a (App1 i)
+ MapWith: type App1 a = (a, ())
+ MapWith: type App2 a b = (a, (b, ()))
+ MapWith: type App3 a b c = (a, (b, (c, ())))
+ MapWith: type App4 a b c d = (a, (b, (c, (d, ()))))
+ MapWith: withFirst :: Traversable t => (a -> Bool -> b) -> t a -> t b
+ MapWith: withLast :: Traversable t => (a -> Bool -> b) -> t a -> t b
- MapWith: (<-^) :: Injectable m => m a (i -> b) -> Injector a i -> InjectedFn a b
+ MapWith: (<-^) :: (Injectable m, CurryTF i b) => m a (FnType i b) -> Injector a i -> InjectedFn a b
- MapWith: (^->) :: Injectable m => m a (i -> b) -> Injector a i -> InjectedFn a b
+ MapWith: (^->) :: (Injectable m, CurryTF i b) => m a (FnType i b) -> Injector a i -> InjectedFn a b
- MapWith: Injector :: (a -> s -> (i, s)) -> s -> Injector a i
+ MapWith: Injector :: (a -> s -> (s, i)) -> s -> Injector a i
- MapWith: adjElt :: Injector a (Maybe a)
+ MapWith: adjElt :: Injector a (App1 (Maybe a))
- MapWith: eltFrom :: Foldable f => f i -> Injector a i
+ MapWith: eltFrom :: [i] -> Injector a (App1 i)
- MapWith: eltFromDef :: Foldable f => i -> f i -> Injector a i
+ MapWith: eltFromDef :: i -> [i] -> Injector a (App1 i)
- MapWith: eltFromMay :: Foldable f => f i -> Injector a (Maybe i)
+ MapWith: eltFromMay :: [i] -> Injector a (App1 (Maybe i))
- MapWith: eltIx :: Integral i => Injector a i
+ MapWith: eltIx :: Integral i => Injector a (App1 i)
- MapWith: isLim :: Injector a Bool
+ MapWith: isLim :: Injector a (App1 Bool)
Files
- ChangeLog.md +20/−0
- MapWith.cabal +39/−26
- README.md +61/−0
- perf/BechmarksPerf.hs +10/−0
- perf/BechmarksSimpl.hs +9/−0
- perf/Benchmarks.hs +236/−0
- perf/IndEnd.hs +0/−11
- perf/IndEndBaseline.hs +0/−13
- perf/PrevNext.hs +0/−8
- perf/PrevNextBaseline.hs +0/−16
- perf/Tuning.hs +449/−0
- src/CurryTF.hs +192/−0
- src/MapWith.hs +344/−89
- test/CurryTFTest.hs +49/−0
- test/MapWithTest.hs +25/−5
ChangeLog.md view
@@ -2,3 +2,23 @@ ## 0.1.0.0 -- 2020-06-24 * First release + +## 0.2.0.0 -- 2020-08-25 +* Significant performance improvements (including fusion) +* New Features: + * An Injector can inject multiple values (for example adj2Elts) + * New Injectors: + * evenElt + * foldlElts and foldl1Elts + * adj2Elts + * New utility functions: + * withFirst + * withLast +* Breaking Changes: + * eltFrom (& similar) now consume a List, not a Foldable. (They never used any features of Foldables, other than converting them to a list). + * Injector functions have two changes. To convert Injectors, change `(\a s -> ... (i, s'))` to `(\a s -> ... (s', app1 i))`: + * the order of the output pair is reversed for consistancy with state transformers, `mapAccumL`, etc. It's now `(new-state, injection-values)`. + * the injector types and values now need to be instances of CurryTF. +* Improved documentation including examples and benchmark stats. +* Also tested in GHC 8.10.1 +
MapWith.cabal view
@@ -1,13 +1,14 @@ name: MapWith -version: 0.1.0.0 +version: 0.2.0.0 -synopsis: mapWith: like fmap, but with additional arguments (isFirst, isLast, etc). +synopsis: mapWith: like fmap, but with additional parameters (isFirst, isLast, etc). category: Combinators maintainer: dj112358@outlook.com description: fmap over Traversables (including lists), but pass additional parameters to the map function, such as isFirst, isLast, prevElt, nextElt, index from start or end, custom params. For examples see https://github.com/davjam/MapWith/blob/master/doc/examples.hs +homepage: https://github.com/davjam/MapWith#readme license: BSD3 license-file: LICENSE @@ -15,8 +16,9 @@ copyright: (c) David James, 2020. build-type: Simple -tested-with: GHC == 8.0.2, GHC == 8.4.3, GHC == 8.8.3 +tested-with: GHC==8.0.2, GHC==8.4.3, GHC==8.8.3, GHC==8.10.1 extra-source-files: ChangeLog.md + README.md cabal-version: >=1.10 @@ -26,58 +28,69 @@ library exposed-modules: MapWith + CurryTF hs-source-dirs: src ghc-options: -Wall other-extensions: ExistentialQuantification default-language: Haskell2010 build-depends: base >= 4.9.1 && < 4.15 - --I know it works on 4.11.1. I believe suspect it will work on 4.14, based on the documentation (e.g. https://hackage.haskell.org/package/base-4.14.0.0/docs/Data-List.html#v:mapAccumL) Test-Suite test-MapWith main-is: MapWithTest.hs Other-modules: MapWith + CurryTF type: exitcode-stdio-1.0 hs-source-dirs: src test default-language: Haskell2010 build-depends: base - ---cabal bench perf-prev-next-baseline --benchmark-options="+RTS -P -hd" ---hp2ps -e8in -c perf-prev-next-baseline.hp ---see https://stackoverflow.com/questions/22942194/profiling-an-executable-with-cabal -benchmark perf-prev-next-baseline - main-is: PrevNextBaseline.hs - hs-source-dirs: perf +Test-Suite test-CurryTF + main-is: CurryTFTest.hs + Other-modules: CurryTF type: exitcode-stdio-1.0 - default-language: Haskell2010 + hs-source-dirs: src test + default-language: Haskell2010 build-depends: base ---cabal bench perf-ind-end-baseline --benchmark-options="+RTS -P -hd" ---hp2ps -e8in -c perf-ind-end-baseline.hp -benchmark perf-ind-end-baseline - main-is: IndEndBaseline.hs - hs-source-dirs: perf +--without -fno-prof-auto, SCCs are added to too many functions and then prevent inlining from happening (which gives bad results for uncurryN) +--supposedly I can control this with a cabal.project file - but so far cabal doesn't seem to pick it up, and none of the options +--here (https://cabal.readthedocs.io/en/latest/cabal-project.html?highlight=cabal.project.local#cfg-field-profiling-detail) seem to be quite what I want. +--So adding SCCs explicitly (per https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/profiling.html#inserting-cost-centres-by-hand) + +--cabal bench tuning --ghc-options="-O2 -ddump-simpl -dsuppress-all -ddump-to-file -fno-prof-auto" +--cabal bench tuning --ghc-options="-O2 -ddump-rule-firings -fno-prof-auto" +--cabal bench tuning --ghc-options="-O2 -fno-prof-auto" --benchmark-options="+RTS -P -hd" +--hp2ps -e8in -c tuning.hp +benchmark tuning + main-is: Tuning.hs + Other-modules: MapWith + CurryTF + hs-source-dirs: src perf type: exitcode-stdio-1.0 default-language: Haskell2010 build-depends: base ---cabal bench perf-prev-next --benchmark-options="+RTS -P -hd" ---hp2ps -e8in -c perf-prev-next.hp -benchmark perf-prev-next - main-is: PrevNext.hs +--cabal bench benchmarks --ghc-options="-O2 -funfolding-use-threshold=150 -fno-prof-auto" --benchmark-options="+RTS -p -RTS" --benchmark-option="100000000 19" +--cabal bench benchmarks --ghc-options="-O2 -funfolding-use-threshold=150 -fno-prof-auto" --benchmark-options="+RTS -P -hd -xt -RTS" --benchmark-option="1000000 19" +--hp2ps -e8in -c benchmarks.hp +benchmark benchmarks + main-is: BechmarksPerf.hs Other-modules: MapWith + CurryTF + Benchmarks hs-source-dirs: src perf type: exitcode-stdio-1.0 default-language: Haskell2010 build-depends: base ---cabal bench perf-ind-end --benchmark-options="+RTS -P -hd" ---hp2ps -e8in -c perf-ind-end.hp -benchmark perf-ind-end - main-is: IndEnd.hs +--cabal bench BenchmarksSimpl --ghc-options="-O2 -ddump-simpl -dsuppress-all -ddump-to-file -fno-prof-auto" +--cabal bench BenchmarksSimpl --ghc-options="-O2 -ddump-rule-firings -fno-prof-auto" +benchmark BenchmarksSimpl + main-is: BechmarksSimpl.hs Other-modules: MapWith + CurryTF + Benchmarks hs-source-dirs: src perf type: exitcode-stdio-1.0 default-language: Haskell2010 build-depends: base -
+ README.md view
@@ -0,0 +1,61 @@+# MapWith [](https://www.stackage.org/package/MapWith) [](https://hackage.haskell.org/package/MapWith) [](https://travis-ci.com/github/davjam/MapWith) + +`mapWith`: like `fmap`, but can "inject" additional parameters such as whether first (or last) element, etc. + +# Background + +I often want to map over a list, but do something slightly different with the first or last element. + +For a long time I used [markbounds](https://stackoverflow.com/questions/14114011/haskell-map-operation-with-different-first-and-last-functions#answer-53282575), +but also wanted something that: + +- works on structures other than lists (`mapWith` works on all `Traversable` types); +- can provide additional types of parameter (not just first/last), such as: + - index from start/end; + - the previous/next element; and +- makes it easy to create new types of parameter to provide; and +- can provide any number of separate parameters to a function (not just a 3-tuple). + +So, after only 2 years, I built a small library to do all of these. + +# Examples + +Passing a "standard combination" of isFirst and isLast parameters: + +``` +let g x f l = [star f, x, star l]; star b = if b then '*' else ' ' +in withFirstLast g "fred" +["*f ", " r ", " e ", " d*"] +``` + +Passing a custom combination of different types of parameter +(the index from the start, whether it's the last element, and elements from another list applied from the right): + +``` +let g x n l e = concat [[x], show n, if l then "*" else "-", e] +in mapWith (g ^-> eltIx & isLast <-^ eltFrom ["x","yy","z","zzzz","y"]) "fred" +["f0-zzzz","r1-z","e2-yy","d3*x"] +``` + +More examples are [here](doc/examples.hs). + +# Questions/Doubts + +Note that this is my first library and my first use of cabal, so I've probably done some dumb things. + +Some things I wonder: + +- Doesn't this already exist? (It feels like it should!) +- Should I name it `Data.Traversable.MapWith`? Or are such names "reserved" for "official" libraries, or something? Would this name impact my own file/directory structures? + +# Future Work + +Areas for potential improvement in later releases: + +- Performance investigations and hopefully improvements, in particular: + - fusion for eltFrom Injectors (unlikely, given the reasons it's not possible for zipWith, but we'll see). + - enhancements for "stateful" "from the right" Injectors (unlikely, given [this](https://stackoverflow.com/questions/63504127/haskell-pinned-or-stack-memory-for-performance)). + +- CurryTF: avoid tuples? (The tuple `(7, ())` is interpreted by `CurryTF` as an application of a single value `7`, but by `Data.Tuple.Curry` as two values: `7` and `()`, + which I think is slightly more confusing than it needs to be.) +
+ perf/BechmarksPerf.hs view
@@ -0,0 +1,10 @@+module Main (main) +where + +import Benchmarks +import System.Environment + +main = do + args <- getArgs --e.g. ["1000000 7"] + let [n, testFnId] = map read $ words $ head args + print $ sum $ testFn testFnId n
+ perf/BechmarksSimpl.hs view
@@ -0,0 +1,9 @@+-- ddump-simpl of BenchmarksPerf is ugly (all the IO read stuff is muddled in with the mapWith code). +-- This unmuddles it. + +module Main (main) +where + +import Benchmarks + +main = print $ sum $ testFn 19 1000000
+ perf/Benchmarks.hs view
@@ -0,0 +1,236 @@+module Benchmarks (testFn, myCycle) +where + +import Data.Function ((&)) +import MapWith +import Data.List.NonEmpty (NonEmpty(..)) +import GHC.Base (build) + +{- +BEWARE: this is very sensitive to changes. +E.g. adding SCC tags, or sharing the list between test fns +can give incorrect benchmarks. +-} + +{-# INLINE testFn #-} +testFn :: Int -> Int -> [Int] +--left-based maps: +testFn 1 n = withFirstRec fnBool [1..n] +testFn 2 n = withFirstScan fnBool [1..n] +testFn 3 n = withFirstMap fnBool [1..n] +testFn 4 n = mapWith (fnBool & isFirst) [1..n] + +testFn 5 n = withPrevRec fnAdj [1..n] +testFn 6 n = withPrevScan fnAdj [1..n] +testFn 7 n = withPrevZip fnAdj [1..n] +testFn 8 n = mapWith (fnAdj ^-> adjElt) [1..n] + +--Right-based maps: +testFn 9 n = withLastRec fnBool [1..n] +testFn 10 n = withLastScan fnBool [1..n] +testFn 11 n = withLastMap fnBool [1..n] +testFn 12 n = mapWith (fnBool & isLast) [1..n] + +testFn 13 n = withNextRec fnAdj [1..n] +testFn 14 n = withNextScan fnAdj [1..n] +testFn 15 n = withNextZip fnAdj [1..n] +testFn 16 n = mapWith (fnAdj <-^ adjElt) [1..n] + +--Left and Right: +testFn 17 n = withFirstLastRec fnBoolBool [1..n] +testFn 18 n = withFirstLastMap fnBoolBool [1..n] +testFn 19 n = withFirstLast fnBoolBool [1..n] +testFn 20 n = map fnBoolBoolTup $ markbounds [1..n] + +testFn 21 n = withPrevNextRec fnAdjAdj [1..n] +testFn 22 n = withPrevNextZip fnAdjAdj [1..n] +testFn 23 n = withPrevNext fnAdjAdj [1..n] + +--Foldl injector: +testFn 30 n = mapWith ((+) ^-> foldlElts (+) 0) [1..n] +testFn 31 n = mapWith ((+) <-^ foldlElts (+) 0) [1..n] --performance not great. data not PINNED. +testFn 32 n = let xs = [1..n] in zipWith (+) xs (scanr (+) 0 xs) --but neither is this. + +--eltIx injector: +testFn 33 n = mapWith ((+) ^-> eltIx) [1..n] +testFn 34 n = mapWith ((+) <-^ eltIx) [1..n] + +--adj2Elts injector: +testFn 35 n = mapWith (fnAdjAdj ^-> adj2Elts) [1..n] +testFn 36 n = mapWith (fnAdjAdj <-^ adj2Elts) [1..n] + +--eltFrom/etc +testFn 37 n = mapWith ((+) ^-> eltFrom [3,5..(n*3)]) [1..n] +testFn 38 n = mapWith ((+) <-^ eltFrom [3,5..(n*3)]) [1..n] +testFn 39 n = mapWith ((+) ^-> eltFromDef 7 [3,12,2,9]) [1..n] +testFn 40 n = mapWith ((+) <-^ eltFromDef 7 [3,12,2,9]) [1..n] +testFn 43 n = mapWith (fnAdj ^-> eltFromMay [3,12,2,9]) [1..n] +testFn 44 n = mapWith (fnAdj <-^ eltFromMay [3,12,2,9]) [1..n] +testFn 45 n = mapWith ((+) ^-> eltFrom (cycle [3,12,2,9]))[1..n] +testFn 46 n = mapWith ((+) <-^ eltFrom (cycle [3,12,2,9]))[1..n] +testFn 47 n = mapWith ((+) ^-> eltFrom (myCycle [3,12,2,9]))[1..n] +testFn 48 n = mapWith ((+) <-^ eltFrom (myCycle [3,12,2,9]))[1..n] + +--Some more fusion tests: +testFn 100 n = take n $ mapWith (fnBool & isFirst) $ repeat (100 :: Int) +testFn 107 n = take n $ mapWith (fnBool & isLast) $ repeat (100 :: Int) +testFn 101 n = take n $ withFirstLast fnBoolBool $ repeat (100 :: Int) +testFn 108 n = take n $ mapWith (fnBool & isFirst) $ cycle ([10,15,19,2] :: [Int]) +testFn 109 n = take n $ mapWith (fnBool & isLast) $ cycle ([10,15,19,2] :: [Int]) +testFn 102 n = take n $ withFirstLast fnBoolBool $ cycle ([10,15,19,2] :: [Int]) +testFn 110 n = take n $ mapWith (fnBool & isFirst) $ myCycle ([10,15,19,2] :: [Int]) +testFn 111 n = take n $ mapWith (fnBool & isLast) $ myCycle ([10,15,19,2] :: [Int]) +testFn 105 n = take n $ withFirstLast fnBoolBool $ myCycle ([10,15,19,2] :: [Int]) + +testFn 103 n = take n $ map fnBoolBoolTup $ markbounds $ repeat (100 :: Int) +testFn 104 n = take n $ map fnBoolBoolTup $ markbounds $ cycle ([10,15,19,2] :: [Int]) +testFn 106 n = take n $ map fnBoolBoolTup $ markbounds $ myCycle ([10,15,19,2] :: [Int]) + + + +myCycle :: [a] -> [a] +myCycle xs = xs' where xs' = xs ++ xs' +{-# NOINLINE [1] myCycle #-} + +{-# RULES "myCycle/build" [~1] forall (f::forall b.(a->b->b) -> b -> b). myCycle (build f) = build (\c _n -> let z = f c z in z) + #-} + +--Hand crafted alternatives to mapWith + +--recursive +withFirstRec :: (a -> Bool -> b) -> [a] -> [b] +withFirstRec f = go True + where + go _ [] = [] + go isFirst (x:xs) = f x isFirst : go False xs + +withPrevRec :: (a -> Maybe a -> b) -> [a] -> [b] +withPrevRec f = go Nothing + where + go _ [] = [] + go prevEltMay (x:xs) = f x prevEltMay : go (Just x) xs + +withLastRec :: (a -> Bool -> b) -> [a] -> [b] +withLastRec f = go + where + go [] = [] + go [x] = f x True : [] + go (x:xs) = f x False : go xs + +withNextRec :: (a -> Maybe a -> b) -> [a] -> [b] +withNextRec f = go + where + go [] = [] + go (x:[]) = f x Nothing : [] + go (x:xs@(n:_)) = f x (Just n) : go xs + +withFirstLastRec :: (a -> Bool -> Bool -> b) -> [a] -> [b] +withFirstLastRec f = go + where + go [] = [] + go [x] = f x True True : [] + go (x:xs) = f x True False : goRest xs + goRest [] = undefined + goRest [x] = f x False True : [] + goRest (x:xs) = f x False False : goRest xs + +withPrevNextRec :: (a -> Maybe a -> Maybe a -> b) -> [a] -> [b] +withPrevNextRec f = go Nothing + where + go _ [] = [] + go prevEltMay (x:[]) = f x prevEltMay Nothing : [] + go prevEltMay (x:xs@(n:_)) = f x prevEltMay (Just n) : go (Just x) xs + +--the original from https://stackoverflow.com/questions/14114011/haskell-map-operation-with-different-first-and-last-functions +markbounds :: [a] -> [(a, Bool, Bool)] +markbounds [] = [] +markbounds [x] = [(x, True, True)] +markbounds (x:xs) = (x, True, False) : tailbound xs + where + tailbound [y] = [(y, False, True)] + tailbound (y:ys) = (y, False, False): tailbound ys + +--scans +withFirstScan :: (a -> Bool -> b) -> [a] -> [b] +withFirstScan f [] = [] +withFirstScan f (x:xs) = map fst $ scanl acc (f x True, False) xs + where + acc (_, isFirst) x = (f x isFirst, False) + +withLastScan :: (a -> Bool -> b) -> [a] -> [b] +withLastScan f [] = [] +withLastScan f xs = map fst $ scanr acc (f (last xs) True, False) (init xs) + where + acc x (_, isLast) = (f x isLast, False) + +withPrevScan :: (a -> Maybe a -> b) -> [a] -> [b] +withPrevScan f [] = [] +withPrevScan f (x:xs) = map fst $ scanl acc (f x Nothing, Just x) xs + where + acc (_, prevMay) x = (f x prevMay, Just x) + +withNextScan :: (a -> Maybe a -> b) -> [a] -> [b] +withNextScan f [] = [] +withNextScan f xs = map fst $ let x = last xs in scanr acc (f x Nothing, Just x) (init xs) + where + acc x (_, nextMay) = (f x nextMay, Just x) + +--map/zip +withFirstMap :: (a -> Bool -> b) -> [a] -> [b] +withFirstMap _ [] = [] +withFirstMap f (x:xs) = f x True : map (flip f False) xs + +withLastMap :: (a -> Bool -> b) -> [a] -> [b] +withLastMap _ [] = [] +withLastMap f xs = map (flip f False) (init xs) ++ [f (last xs) True] + +withPrevZip :: (a -> Maybe a -> b) -> [a] -> [b] +withPrevZip f xs = zipWith f xs (Nothing : map Just xs) + +withNextZip :: (a -> Maybe a -> b) -> [a] -> [b] +withNextZip f xs = zipWith f xs $ map Just (tail xs) ++ [Nothing] + +withFirstLastMap :: (a -> Bool -> Bool -> b) -> [a] -> [b] +withFirstLastMap _ [] = [] +withFirstLastMap f [x] = [f x True True] +withFirstLastMap f (x:xs) = f x True False : map (\x -> f x False False) (init xs) ++ [f (last xs) False True] + +withPrevNextZip :: (a -> Maybe a -> Maybe a -> b) -> [a] -> [b] +withPrevNextZip f xs = zipWith3 f xs (Nothing : map Just xs) (map Just (tail xs) ++ [Nothing]) + +--injected functions +fnBool :: Int -> Bool -> Int +fnBool n True = n * 9 +fnBool n False = n * 8 + +fnAdj :: Int -> Maybe Int -> Int +fnAdj n Nothing = n * 9 +fnAdj n (Just m) = (n + m) * 8 + +fnBoolBool :: Int -> Bool -> Bool -> Int +fnBoolBool n True True = n * 9 +fnBoolBool n True False = n * 8 +fnBoolBool n False True = n * 7 +fnBoolBool n False False = n * 6 + +fnBoolBoolTup :: (Int, Bool, Bool) -> Int +fnBoolBoolTup (n, True , True ) = n * 9 +fnBoolBoolTup (n, True , False) = n * 8 +fnBoolBoolTup (n, False, True ) = n * 7 +fnBoolBoolTup (n, False, False) = n * 6 + +{-# INLINE fnAdjAdj #-} --INLINE makes test 35 fast. (But doesn't impact test 36). +fnAdjAdj :: Int -> Maybe Int -> Maybe Int -> Int +fnAdjAdj n Nothing Nothing = n * 9 +fnAdjAdj n (Just m) Nothing = (n + m ) * 8 +fnAdjAdj n Nothing (Just p) = (n + p) * 7 +fnAdjAdj n (Just m) (Just p) = (n + m + p) * 6 + +{- +This has the same effect on test 35 as marking INLINE. +fnAdjAdj n mMay pMay = + case pMay of Nothing -> case mMay of Nothing -> n * 9 + (Just m) -> (n + m ) * 8 + (Just p) -> case mMay of Nothing -> (n + p) * 7 + (Just m) -> (n + m + p) * 6 +-}
− perf/IndEnd.hs
@@ -1,11 +0,0 @@- - -import MapWith - -main = do - print $ sum $ withEndIx xxx [1..1000000] - where - xxx n nEndInd = n + nEndInd - -withEndIx :: Traversable t => (a -> Int -> b) -> t a -> t b -withEndIx f = mapWith $ f <-^ eltIx
− perf/IndEndBaseline.hs
@@ -1,13 +0,0 @@-{-# LANGUAGE BangPatterns #-} - -import Data.Traversable (mapAccumR) - -main = do - print $ sum $ withEndIx xxx [1..1000000] - where - xxx n nEndInd = n + nEndInd - -withEndIx :: Traversable t => (a -> Int -> b) -> t a -> t b -withEndIx f !t = snd $ mapAccumR acc 0 t - where - acc !i a = (i+1, f a i)
− perf/PrevNext.hs
@@ -1,8 +0,0 @@-import MapWith -import Data.Maybe (fromMaybe) - -main = do - print $ sum $ withPrevNext xxx [1..1000000] - where - xxx :: Int -> Maybe Int -> Maybe Int -> Int - xxx n prevMay nextMay = n + fromMaybe 0 prevMay + fromMaybe 0 nextMay
− perf/PrevNextBaseline.hs
@@ -1,16 +0,0 @@-import Data.Traversable (mapAccumL, mapAccumR) -import Data.Maybe (fromMaybe) - -main = do - print $ sum $ withPrevNext xxx [1..1000000] - where - xxx :: Int -> Maybe Int -> Maybe Int -> Int - xxx n prevMay nextMay = n + fromMaybe 0 prevMay + fromMaybe 0 nextMay - -withPrevNext :: Traversable t => (a -> Maybe a -> Maybe a -> b) -> t a -> t b -withPrevNext f = snd . mapAccumR accR Nothing . snd . mapAccumL accL Nothing - where - accL prevMay a = (Just a, (a, f a prevMay)) - accR nextMay (a, fap) = (Just a, fap nextMay) - -
+ perf/Tuning.hs view
@@ -0,0 +1,449 @@+{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module Main (main) where + +import Data.Traversable (mapAccumL) +import Data.Function ((&)) +import MapWith +import CurryTF + +main = mainP + +mainA = print $ sum $ mapWith (fn2 <-^ eltIx) $ take 100 primes + +--This file is for various experiments in tuning. +--These have so far shown where addition of INLINABLE pragmas is very beneficial. +--As a result, I now have comperable performance to the "baselines". +--I don't (yet) have comperable performance to markbounds, which remains a challenge. + + +-- This demostrates that the 61 is not "inlined" (at bce9a33), just like in the MultiInjectors branch. But could it be? +mainB = print $ sum $ mapWith (fn2 ^-> constInjB) $ take 100 primes + +fn2 :: Int -> Int -> Int +fn2 w x | w > 10 = fn2 (w - 6) (x - 15) + | otherwise = w + x + +constInjB :: Injector a (App1 Int) +constInjB = Injector (\_ _ -> ((), app1 61)) () + +{- +Depends on INLINABLE in MapWith: + +^-> mapWith core +no no main11 = I# 61# +yes yes case $wfn 102# 61# of ww_s93b +yes no main11 = I# 61# +no yes case $wfn 102# 61# of ww_s93b +-} + +mainB' = print $ sum $ mapWith (fn3 ^-> constInjB ^-> constInjB') $ take 100 primes + +constInjB' :: Injector a (App1 Int) +constInjB' = Injector (\_ _ -> ((), app1 65)) () + +fn3 :: Int -> Int -> Int -> Int +fn3 w x y | w > 10 = fn3 (w - 6) (x - 15) (y + 2) + | otherwise = w + x + y + +-- now not inlined (either 61 or 65) (even with INLINABLE on mapWith, ^-> (both insts), injPair, and -fspecialise-aggressively -fexpose-all-unfoldings, SPECIALISE on ^-> + +-- BUT does with INLINE (on all) +-- Also without INLINE on ^-> (I guess GHC makes these "INLINABLE" anyway?) +-- Only if injPair INLINE, not INLINABLE +-- Buy MapWith INLINABLE is OK. (even w/o -fspecialise-aggressively -fexpose-all-unfoldings, SPECIALISE) + +--HENCE INLINE on injPair and INLINABLE on mapWith seems to give best results. + +{- +But - what does it do to performance of perf-ind-end? +with INLINE/ABLEs: (2nd run) + total time = 0.26 secs (260 ticks @ 1000 us, 1 processor) + total alloc = 344,046,128 bytes (excludes profiling overheads) +without: + total time = 0.50 secs (497 ticks @ 1000 us, 1 processor) + total alloc = 720,046,296 bytes (excludes profiling overheads) + +So pretty good! Vs "baseline": + total time = 0.21 secs (206 ticks @ 1000 us, 1 processor) + total alloc = 352,045,968 bytes (excludes profiling overheads) + +Hoorah! + +Checking perf-prev-next: +with: + total time = 0.17 secs (169 ticks @ 1000 us, 1 processor) + total alloc = 488,045,968 bytes (excludes profiling overheads) + +without: + total time = 0.74 secs (738 ticks @ 1000 us, 1 processor) + total alloc = 1,320,046,304 bytes (excludes profiling overheads) + +baseline: + total time = 0.18 secs (180 ticks @ 1000 us, 1 processor) + total alloc = 488,045,968 bytes (excludes profiling overheads) + +Blimey. +-} + +{- The above is all without the CurryTF stuff. With it (amazingly) we still inline. Checking performance: +perf ind-end: + total time = 0.31 secs (311 ticks @ 1000 us, 1 processor) + total alloc = 392,046,128 bytes (excludes profiling overheads) + +perf-prev-next: + total time = 0.20 secs (199 ticks @ 1000 us, 1 processor) + total alloc = 512,045,968 bytes (excludes profiling overheads) + +so a slight degradation. Why? + +Comparing mainB: curry & uncurry (with INLINE/ABLEs) are identical. + +Comparing mainA, curry has case i_a5xN of { (arg1_au0, moreArgs1_au1), so is not inlining the recursive uncurryN calls. +(Although we can see from CurryNPerf that (surpisingly?) it is capable of doing so). + +Now with INLINABLE in eltIx etc: +-- perf-ind-end: + total time = 0.16 secs (164 ticks @ 1000 us, 1 processor) + total alloc = 216,045,936 bytes (excludes profiling overheads) +(Hmmm better that the baseline???) + +-- perf-prev-next: + total time = 0.18 secs (182 ticks @ 1000 us, 1 processor) + total alloc = 512,045,968 bytes (excludes profiling overheads) +-} + +--But: +mainC = print $ sum $ injFwd constInjC fn2 $ take 100 primes + +constInjC :: Injector a Int +constInjC = Injector (\_ _ -> ((), 62)) () + +--core has: main5 = case $wfn 101# 61# of ww_s6fD { __DEFAULT -> I# ww_s6fD } + +injFwd :: Traversable t => Injector a i -> (a -> i -> b) -> t a -> t b +injFwd (Injector nxt z) f = snd . mapAccumL acc z + where + acc s a = let (s', i) = nxt a s in (s', f a i) + +--And with a non-const list: + +primes = filterPrime [2..] + where filterPrime (p:xs) = + p : filterPrime [x | x <- xs, x `mod` p /= 0] + +mainD = print $ sum $ injFwd constInjD fn2 $ take 100 primes + +constInjD :: Injector a Int +constInjD = Injector (\_ _ -> ((), 63)) () + +--Still yes: case $wfn_r736 ww2_s6VS 63# of ww3_s6W0 (A bit weird: the 63 is in there four times). + +mainE = print $ sum $ myMapWith (fn2 ^*> constInjE) $ take 100 primes + +constInjE :: Injector a Int +constInjE = Injector (\_ _ -> ((), 64)) () + +data MyInjectedFn a b + = forall l r. MyInjectedFnLR (a -> l -> r -> b) (Injector a l) (Injector a r) + | forall l . MyInjectedFnL (a -> l -> b) (Injector a l) + | forall r. MyInjectedFnR (a -> r -> b) (Injector a r) + +myMapWith (MyInjectedFnL f (Injector gen z)) = snd . mapAccumL acc z + where acc s a = let (s', i) = gen a s in (s', f a i) + +(^*>) :: (a -> i -> b) -> Injector a i -> MyInjectedFn a b +f ^*> itL' = MyInjectedFnL (\a l -> f a l) itL' + + +-- still inlined! case $wfn_r7ho ww1_s79P 64# of ww2_s79X { __DEFAULT -> + +mainF = print $ sum $ myMapWith (fn3 ^*> constInjF ^**> constInjF') $ take 100 primes + +constInjF :: Injector a Int +constInjF = Injector (\_ _ -> ((), 66)) () + +constInjF' :: Injector a Int +constInjF' = Injector (\_ _ -> ((), 67)) () + + +MyInjectedFnL f itL ^**> itL' = MyInjectedFnL (\a (l, l') -> f a l l') (injPair itL itL') + +injPair :: Injector a i1 -> Injector a i2 -> Injector a (i1, i2) +injPair (Injector n1 z1) (Injector n2 z2) = Injector nxt (z1, z2) + where + nxt a ~(s1, s2) = let (i1, s1') = n1 a s1 -- !! NOTE THE ~ !! It allows "constant" injectors (e.g. isLim), and hence e.g. andFirstLast to work on infinite lists. + (i2, s2') = n2 a s2 + in ((i1, i2), (s1', s2')) + +--inlined! case $wfn3 ww1_s7iF 66# 67# of ww2_s7iR { __DEFAULT -> +-- even without -fspecialise-aggressively -fexpose-all-unfoldings + +--This is uses a local copy of Curry, and is inlined (so it is possible!) +mainG = print $ sum $ myMapWith (fn2 ^+> myEltIx) $ take 100 primes + +myEltIx :: Integral i => Injector a (i, ()) +myEltIx = Injector (\_ i -> (i+1, (i, ()))) 0 + +(^+>) :: MyCurryN i b => (a -> MyFnType i b) -> Injector a i -> MyInjectedFn a b +f ^+> itL' = MyInjectedFnL (\a l -> f a $## l) itL' + +($##) :: MyCurryN args r => MyFnType args r -> args -> r +f $## args = (myUncurryN f) args + +class MyCurryN args r where + type MyFnType args r :: * + myUncurryN :: MyFnType args r -> args -> r + +instance MyCurryN () r where + type MyFnType () r = r + myUncurryN f () = f + +instance MyCurryN moreArgs r => MyCurryN (arg, moreArgs) r where + type MyFnType (arg, moreArgs) r = arg -> (MyFnType moreArgs r) + myUncurryN f (arg, moreArgs) = myUncurryN (f arg) moreArgs + +--mainH also uses local Curry, but eltIx from MapWith, and isn't inlined! +mainH = print $ sum $ myMapWith (fn2 ^+> eltIx) $ take 100 primes + +--But is if we set INLINABLE on eltIx! + + +--ABOVE here: gets perf equiv to "baselines". But they use mapAccumL/R, and don't seem to fuse. +--Ideally I'd like performance similar to markbounds, so there's more work to do... + +mainJ = print $ sum $ map fn2Tup $ markbounds [1..1000000] + +fn2Tup (x, True, _ ) = x + 10 +fn2Tup (x, _, True) = x * 2 +fn2Tup (x, _, _ ) = x + +markbounds :: [a] -> [(a, Bool, Bool)] +markbounds [] = [] +markbounds [x] = [(x, True, True)] +markbounds (x:xs) = (x, True, False) : tailbound xs + where + tailbound [y] = [(y, False, True)] + tailbound (y:ys) = (y, False, False): tailbound ys + + +{- mainJ: + total time = 0.10 secs (99 ticks @ 1000 us, 1 processor) + total alloc = 176,045,824 bytes (excludes profiling overheads) +-} + +mainK = print $ sum $ withFirstLast fn2Args [1..1000000] + +fn2Args x True _ = x + 10 +fn2Args x _ True = x * 2 +fn2Args x _ _ = x + +{- mainK: + total time = 0.29 secs (290 ticks @ 1000 us, 1 processor) + total alloc = 488,045,920 bytes (excludes profiling overheads) +-} + +mainL = print $ sum ([1..1000000] :: [Int]) + +{- Very good: doesn't create a list. + + total time = 0.00 secs (0 ticks @ 1000 us, 1 processor) + total alloc = 45,912 bytes (excludes profiling overheads) + +$wgo + = \ counter sumSoFar -> + case counter of counter' { + __DEFAULT -> $wgo (+# counter' 1#) (+# sumSoFar counter'); + 1000000# -> +# sumSoFar 1000000# + } + +main2 + = case $wgo 1# 0# of theSum { __DEFAULT -> + case $wshowSignedInt 0# theSum [] of { (# showRslt1, showRslt2 #) -> + : showRslt1 showRslt12 + } + } +-} + +mainM = print $ sum $ mapWith (fn1Arg & isFirst) [1..1000000] +-- perfect! +fn1Arg :: Int -> Bool -> Int +fn1Arg n True = n * 78 +fn1Arg n False = n +--{-# NOINLINE fn1Arg #-} + +mainN = print $ sum $ mapWith (fn4 & prevElt) [1..1000000] +--also perfect! +fn4 :: Int -> Maybe Int -> Int +fn4 x (Just y) = x + y +fn4 x Nothing = x * 2 + +mainP = print $ sum $ mapWith (fn1Arg ^-> evenElt) [1..1000000] +--perfect with Injector-based evenElt. + +{- Wow! It does two numbers with each loop! +main_$s$wgo + = \ sumSoFar n -> + case n of n' { + __DEFAULT -> + let { nPlus1 = +# n' 1# } in + main_$s$wgo (+# (+# sumSoFar (*# n' 78#)) nPlus1) (+# nPlus1 1#); + 999999# -> +# (+# sumSoFar 77999922#) 1000000#; + 1000000# -> +# sumSoFar 78000000# + } + +main2 + = case main_$s$wgo 0# 1# of and ... +-} + +mainQ = print $ sum $ mapWith (fn1Arg <-^ isLim) [1..1000000] + +{- With myMapAccumR fusion attempt: + + total time = 0.08 secs (79 ticks @ 1000 us, 1 processor) + total alloc = 72,045,872 bytes (excludes profiling overheads) + + +$wgo (prev means "to the right") + = \ n -> + (# False, + \ x -> + case n { + __DEFAULT -> + case $wgo (+# n 1#) of { (# prevState, prevFn #) -> + prevFn + (case prevState of { + False -> I# (+# x n); + True -> I# (+# x (*# n 78#)) + }) + }; + 1000000# -> (+# x 78000000#) } + } #) + +main2 + = case $wgo 1# of { (# _, ansFn #) -> + case ansFn 0# of { I# ans -> + case $wshowSignedInt 0# ans ... + +-} + + +-- FUSION unwind rules +-- ~~~~~~~~~~~~~~~~~~~ + +{- # RULES +"eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) +"eftIntList" [1] eftIntFB (:) [] = eftInt +"take" [~1] forall n xs . take n xs = + build (\c nil -> if 0 < n + then foldr (takeFB c nil) (flipSeqTake nil) xs n + else nil) +"unsafeTakeList" [1] forall n xs . foldr (takeFB (:) []) (flipSeqTake []) xs n + = unsafeTake n xs + # -} + + +mainFUa = print $ take 3 ([1..1000000] :: [Int]) +{- +MISSING???: eftInt +Rule fired: take (GHC.List) +Rule fired: fold/build (GHC.Base) + +take 3 (eftInt 1 1000000) +build (\c nil -> foldr (takeFB c nil) (flipSeqTake nil) (eftInt 1 1000000) 3) +build (\c nil -> foldr (takeFB c nil) (flipSeqTake nil) (build (\c n -> eftIntFB c n 1 1000000)) 3) +build (\c nil -> (\c n -> eftIntFB c n 1 1000000) (takeFB c nil) (flipSeqTake nil) 3) +build (\c nil -> (eftIntFB (takeFB c nil) (flipSeqTake nil) 1 1000000) 3) +(eftIntFB (takeFB (:) []) (flipSeqTake nil) 1 1000000) 3 +-} + + +mainFUb = print $ take 3 $ tail ([1..1000000] :: [Int]) --unfuses +{- + +??? MISSING "eftInt" +Rule fired: take (GHC.List) +Rule fired: eftIntList (GHC.Enum) +Rule fired: unsafeTakeList (GHC.List) + +take 3 (tail (eftInt 1 1000000)) +build (\c nil -> foldr (takeFB c nil) (flipSeqTake nil) (tail (eftInt 1 1000000)) n 3) "take" +build (\c nil -> foldr (takeFB c nil) (flipSeqTake nil) (tail (build (\c n -> eftIntFB c n 1 1000000))) n 3) "eftInt" + +build (\c nil -> foldr (takeFB c nil) (flipSeqTake nil) (tail (eftIntFB (:) [] 1 1000000)) n 3) +build (\c nil -> foldr (takeFB c nil) (flipSeqTake nil) (tail (eftInt 1 1000000)) n 3) "eftIntList" +foldr (takeFB (:) []) (flipSeqTake nil) (tail (eftInt 1 1000000)) n 3 +unsafeTake 3 (tail (eftInt 1 1000000)) "unsafeTakeList" +-} + +{- +sum = foldl (+) 0 +foldl k z0 xs = foldr (\v fn \z -> fn (k z v)) id xs z0 + +isFirst f = f ^-> isLim +isLim = Injector (\_ i -> (app1 i, False)) True +f ^-> itL' = InjectedFnL (\a l -> f a $# l) itL' +mapWith (InjectedFnL f (Injector gen z)) = mySnd . myMapAccumL acc z where acc s a = let (i, s') = gen a s in (s', f a i) +mySnd (myMapAccumL f z xs) = build (\c nil -> foldr (mapAccumLFB c f) (flipSeqMapAccumL nil) xs z) + +fnBool & isFirst +fnBool ^-> isLim +InjectedFnL (\a l -> fnBool a $# l) (Injector (\_ i -> (app1 i, False)) True) +InjectedFnL (\a l -> fnBool a l) (Injector (\_ i -> (i, False)) True) +-} + +mainFUc = print $ sum $ take 3 $ mapWith (fnBool & isFirst) ([1..1000000] :: [Int]) +{- +??? MISSING "eftInt" +Rule fired: take (GHC.List) +Rule fired: sndMapAccumL (MapWith) +Rule fired: fold/build (GHC.Base) +Rule fired: fold/build (GHC.Base) +Rule fired: fold/build (GHC.Base) + +sum (take 3 (mapWith (fnBool & isFirst) (eftInt 1 1000000))) + +foldl (+) 0 (take 3 (mapWith (fnBool & isFirst) (eftInt 1 1000000))) +foldr (\v fn \z -> fn (z + v)) id (take 3 (mapWith (fnBool & isFirst) (eftInt 1 1000000))) 0 +foldr (\v fn \z -> fn (z + v)) id build (\c nil -> foldr (takeFB c nil) (flipSeqTake nil) (mapWith (fnBool & isFirst) (eftInt 1 1000000)) 3) 0 +(\c nil -> foldr (takeFB c nil) (flipSeqTake nil) (mapWith (fnBool & isFirst) (eftInt 1 1000000)) 3) (\v fn \z -> fn (z + v)) id 0 +foldr (takeFB (\v fn \z -> fn (z + v)) id) (flipSeqTake nil) (mapWith (fnBool & isFirst) (eftInt 1 1000000)) 3) 0 +... + +mapWith (fnBool & isFirst) ([1..1000000] :: [Int]) +mapWith (fnBool & isFirst) (eftInt 1 1000000) +snd (mapAccumL acc True (eftInt 1 1000000)) where acc s a = let (i, s') = (\_ i -> (i, False)) a s in (s', injfn a i) +build (\c nil -> foldr (mapAccumLFB c acc) (flipSeqMapAccumL nil) (eftInt 1 1000000) True) where acc s a = let (i, s') = (\_ i -> (i, False)) a s in (s', injfn a i) +build (\c nil -> foldr (mapAccumLFB c acc) (flipSeqMapAccumL nil) (build (\ c n -> eftIntFB c n x y)) True) where acc s a = let (i, s') = (\_ i -> (i, False)) a s in (s', injfn a i) +build (\c nil -> (\ c n -> eftIntFB c n x y) (mapAccumLFB c acc) (flipSeqMapAccumL nil) True) where acc s a = let (i, s') = (\_ i -> (i, False)) a s in (s', injfn a i) +build (\c nil -> (eftIntFB (mapAccumLFB c acc) (flipSeqMapAccumL nil) x y) True) where acc s a = let (i, s') = (\_ i -> (i, False)) a s in (s', injfn a i) +(eftIntFB (mapAccumLFB (:) acc) (flipSeqMapAccumL []) x y) True where acc s a = let (i, s') = (\_ i -> (i, False)) a s in (s', injfn a i) +-} + +mainFUd = print $ mapWith (fnBool & isFirst) $ tail ([1..10] :: [Int]) + +{- +mapWith (fnBool & isFirst) $ tail ([1..1000000] :: [Int]) +mapWith (fnBool & isFirst) (tail (eftInt 1 1000000)) +snd (mapAccumL acc True (tail (eftInt 1 1000000))) where acc s a = let (i, s') = (\_ i -> (i, False)) a s in (s', injfn a i) +build (\c nil -> foldr (mapAccumLFB c acc) (flipSeqMapAccumL nil) (tail (eftInt 1 1000000)) True) where acc s a = let (i, s') = (\_ i -> (i, False)) a s in (s', injfn a i) +build (\c nil -> foldr (mapAccumLFB c acc) (flipSeqMapAccumL nil) (tail (build (\ c n -> eftIntFB c n x y))) True) where acc s a = let (i, s') = (\_ i -> (i, False)) a s in (s', injfn a i) +foldr (mapAccumLFB (:) acc) (flipSeqMapAccumL []) (tail (build (\ c n -> eftIntFB c n x y))) True where acc s a = let (i, s') = (\_ i -> (i, False)) a s in (s', injfn a i) +foldr (mapAccumLFB (:) acc) (flipSeqMapAccumL []) (tail (eftIntFB (:) [] x y)) True where acc s a = let (i, s') = (\_ i -> (i, False)) a s in (s', injfn a i) +foldr (mapAccumLFB (:) acc) (flipSeqMapAccumL []) (tail (eftInt x y)) True where acc s a = let (i, s') = (\_ i -> (i, False)) a s in (s', injfn a i) + +We want this... +snd (mapAccumL acc True (tail (eftInt x y))) where acc s a = let (i, s') = (\_ i -> (i, False)) a s in (s', injfn a i) + +-} + +mainFUe = print $ tail $ mapWith (fnBool & isFirst) $ tail ([1..10] :: [Int]) + +fnBool :: Int -> Bool -> Int +fnBool n True = n * 9 +fnBool n False = n * 8 + +mainX = print $ sum $ take 100000000 $ mapWith (fnBool & isFirst) (repeat (100 :: Int))
+ src/CurryTF.hs view
@@ -0,0 +1,192 @@+{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : CurryTF +Description : Provides curry/uncurry-like function for any number of parameters +Copyright : (c) David James, 2020 +License : BSD3 +Stability : Experimental + +A generalisation of 'curry' and 'uncurry' , allowing currying of any number of arguments of different types. + + +For the class instances provided here, the arguments are packaged into a "stacked tuple". +For example @(\'x\', (3 :: Int, (True, ())))@ represents a set of three arguments of different types: + +- @\'x\' :: Char@; +- @3 :: Int@; and +- @True :: Bool@. + +The TF stands for Type Family. I've given this the (possibly weird) name to avoid any conflict with similar implementations. +-} + +module CurryTF + ( + -- * Class + CurryTF(..) + , ($#) + + -- * Stacking Helpers + -- $StackingFunctions + , App1, App2, App3, App4 + , app1, app2, app3, app4 + + -- * Custom CurryTF Implementations + -- $CustomArgApp + + -- * Other Implementations + -- $SeeAlso + ) +where + +{- | +Given: + +- a type 'args' containing n embedded arguments; and +- a result type 'r' + +@CurryTF args r@ represents the ability to convert either way between functions: + +- @fCurried :: /each/ -> /argument/ -> /as/ -> /a/ -> /separate/ -> /parameter/ -> r@; and +- @fUncurried :: /all-arguments-embedded-in-a-single-parameter/ -> r@. + +so that: + +- @fCurried = curryN fUncurried@; and +- @fUncurried = uncurryN fCurried@. +-} + +class CurryTF args r where + {- | + The type of the (curried) function that can have arguments of the types embedded in 'args' applied and that returns a result of type 'r'. + For example: + + >>> :kind! FnType (Char, (Int, (Bool, ()))) String + FnType (Char, (Int, (Bool, ()))) String :: * + = Char -> Int -> Bool -> [Char] + -} + type FnType args r :: * + + {- | + Embeds a number of separate arguments into a single 'args' parameter, applies 'args' to a function, and returns the result. + + For example: + + >>> fn1 (c, (n, (b, ()))) = c : replicate n '1' ++ if b then "hello" else "goodbye" + >>> curryN fn1 'x' 3 True + "x111hello" + + This also support partial application: + + >>> :t curryN fn1 'x' + curryN fn1 'x' :: Int -> Bool -> [Char] + -} + + curryN :: (args -> r) -> FnType args r + + {- | + Applies each argument embedded in 'args' as a separate parameter to a function, and returns the result. + + For example: + + >>> fn2 c n b = c : replicate n '2' ++ if b then "hello" else "goodbye" + >>> uncurryN fn2 ('x', (3, (True, ()))) + "x222hello" + -} + uncurryN :: FnType args r -> args -> r + +-- | the application of zero arguments, giving @r@ +instance CurryTF () r where + type FnType () r = r + curryN f = f () + uncurryN f () = f + +-- | the application of @arg@, followed by the application of @moreArgs@ (recursively), giving @r@ +instance CurryTF moreArgs r => CurryTF (arg, moreArgs) r where + type FnType (arg, moreArgs) r = arg -> FnType moreArgs r + curryN f a = curryN (\t -> f (a, t)) + uncurryN f (arg, moreArgs) = uncurryN (f arg) moreArgs + +-- | A binary operator for 'uncurryN', so if values a, b and c are embedded in @args@ then @f $# args = f a b c@ +($#) :: CurryTF args r => FnType args r -> args -> r +f $# args = uncurryN f args + +{- $StackingFunctions +These types and functions can make code that uses the "stacked tupples" look a little less weird. For example, you can write: + +>>> fn2 $# app3 'x' 3 True + +instead of + +>>> fn2 $# ('x', (3, (True, ()))) + +Although these are only provided here for 1 to 4 arguments, you can use the "stacked tuple" to apply any number of arguments. +-} +{-# INLINABLE app1 #-} +{-# INLINABLE app2 #-} +{-# INLINABLE app3 #-} +{-# INLINABLE app4 #-} + +type App1 a = (a, ()) +-- ^ A "stacked tuple" of one value +type App2 a b = (a, (b, ())) +-- ^ A "stacked tuple" of two values +type App3 a b c = (a, (b, (c, ()))) +-- ^ A "stacked tuple" of three values +type App4 a b c d = (a, (b, (c, (d, ())))) +-- ^ A "stacked tuple" of four values + +app1 :: a -> App1 a +-- ^ stacks one value +app2 :: a -> b -> App2 a b +-- ^ stacks two values +app3 :: a -> b -> c -> App3 a b c +-- ^ stacks three values +app4 :: a -> b -> c -> d -> App4 a b c d +-- ^ stacks four values + +app1 a = (a, ()) +app2 a b = (a, (b, ())) +app3 a b c = (a, (b, (c, ()))) +app4 a b c d = (a, (b, (c, (d, ())))) + +{- $CustomArgApp +It is possible to define instances for other types, for example: + +@ +data MyStuff = MyStuff Char Int Bool + +instance CurryTF MyStuff r where + type FnType MyStuff r = Char -> Int -> Bool -> r + curryN f c n b = f (MyStuff c n b) + uncurryN f (MyStuff c n b) = f c n b +@ + +then: + +>>> fn2 $# MyStuff 'y' 5 False +"y22222goodbye" +>>> fn3 (MyStuff c n b) = c : show n ++ show b +>>> curryN fn3 'p' 8 False +"p8False" + +Doing this, especially for a type with multiple constructors, may not be sensible. +-} + +{- $SeeAlso +There are similar implementations in: + +1. [Data.Tuple.Curry](https://hackage.haskell.org/package/tuple/docs/Data-Tuple-Curry.html); and +1. [Data.Tuple.Ops](https://hackage.haskell.org/package/tuple-sop/docs/Data-Tuple-Ops.html). + +These both take tuples of the form (arg1, arg2, .., argn), which is arguably easier to use. + +I built this (instead of using those), for good and bad reasons including: + +- I'm trying to improve my Haskell. TypeFamilies seemed to help here, so I got to start using those too. +- (1) has a limit of 32 args. OK that's probably enough, but it just seemed wrong to have any restriction. +- (2) Seems a little complex, and excesive for the needs here. (Though, from what I've read so far, the "stacked-tuples" here are in SOP form?). They also have a limit - in this case 10 args. +-}
src/MapWith.hs view
@@ -1,9 +1,10 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE BangPatterns #-} -- | -- Module : MapWith --- Description : blah +-- Description : Provides the fmap-like functions -- Copyright : (c) David James, 2020 -- License : BSD3 -- Stability : Experimental @@ -13,6 +14,8 @@ -- * whether the first / last item -- * the previous / next item -- * the index from the start / end +-- +-- It offers excellent [performance](#Performance). module MapWith ( @@ -21,7 +24,9 @@ -- * Pre-Packaged Maps -- $PrePackagedMaps - withFirstLast + withFirst + , withLast + , withFirstLast , andFirstLast , withPrevNext , andPrevNext @@ -34,17 +39,20 @@ , foldMapWith , InjectedFn , Injectable(..) - -- * Predefined Injectors -- $PredefinedInjectors , isLim , adjElt + , adj2Elts , eltIx + , evenElt + , foldlElts + , foldl1Elts , eltFrom , eltFromMay , eltFromDef - + -- ** Pre-Combined Injectors -- $PrecombinedInjectors , isFirst @@ -54,27 +62,46 @@ -- * Custom Injectors , Injector(..) + + -- ** Stacked-Tuple Helpers + -- $StackedTupleHelpers + , module CurryTFExps --these are very helpful for building Injectors. Someone can import CurryTF if they want more. + + -- * Performance + -- $Performance + + -- ** Benchmarks + -- $Benchmarks + + -- ** Fusion + -- $Fusion ) where -import Data.Foldable (fold, toList) +import CurryTF +import qualified CurryTF as CurryTFExps (App1, App2, App3, App4, app1, app2, app3, app4) + +import Data.Foldable (fold) import Data.Traversable (mapAccumL, mapAccumR) import Data.Function ((&)) import Control.Exception (assert) +import GHC.Base (build) -- $TypeNames --- These 'names' are used for types and variables throughout: +-- These names are used for types and variables throughout: -- -- [@t@]: the 'Traversable' we're mapping over --- [@a@]: the value in the input 'Traversable' --- [@b@]: the result in the output 'Traversable' --- [@i@]: an output from an 'Injector', injected into a map function +-- [@a@]: a value in the input 'Traversable' +-- [@b@]: a result in the output 'Traversable' +-- [@i@]: an output from an 'Injector', injected into a map function. (i may represent one than one injected value). -- [@s@]: the internal state in an 'Injector' ---XXXX I'd like to add separate comments for each argument, but that's not supported to GHC 8.6 https://github.com/haskell/haddock/issues/836#issuecomment-391402361 -data Injector a i = forall s. Injector (a -> s -> (i, s)) s -- ^the first argument is a generate function, the second argument is the initial state. +--XXXX I'd like to add separate comments for each parameter, but that's not supported to GHC 8.6 https://github.com/haskell/haddock/issues/836#issuecomment-391402361 +data Injector a i = forall s. Injector (a -> s -> (s, i)) s -- ^the first parameter is a generate function, the second parameter is the initial/prior state. --- ^ Injectors have an initial state and a generate function. +-- ^ An @Injector a i@ can be used with 'mapWith' to map over a 'Traversable' containing elements of type @a@, injecting values according to the type @i@ as it goes. +-- +-- Injectors have an initial state and a generate function. -- -- For each item in the 'Traversable', the generate function can use both: -- @@ -83,112 +110,235 @@ -- -- to determine both: -- --- - the injection value, and --- - the new state. +-- - the new state, and +-- - the injection value(s) -- --- The first value to inject is determined by a first call to the generate function. +-- The injection value(s) must be an @args@ (per 'CurryTF'), in order for the injector to work with the '^->' and '<-^' operators. +-- These can be created by: +-- +-- - (recommended) using 'app1', 'app2', etc; +-- - by nesting the values appropriately e.g @(i1, ())@ or @(i1, (i2, (i3, (i4, (i5, .. () ..)))))@; or +-- - defining a new instance of 'CurryTF' +-- +-- The first value(s) to inject is/are determined by a first call to the generate function. -- The first call to the generate function is with the first (if combined with '^->') or last (if combined with '<-^') item from the 'Traversable' and the initial state. -- -- For example: -- --- >>> funnyNext a s = (a + s, a + 1) +-- >>> funnyNext a s = (a + 1, app1 $ a + s) -- >>> funnyInjector = Injector funnyNext 17 -- >>> mapWith ((\_ i -> i) ^-> funnyInjector) [4,8,3] -- [21,13,12] -- --- +-------+---------------+------+---------------+-----------------+ --- + Call + Initial State + Item + Injection + New State + --- +=======+===============+======+===============+=================+ --- + 1 + 17 + 4 + 17+4=__21__ + 4+1=5 + --- +-------+---------------+------+---------------+-----------------+ --- + 2 + 5 + 8 + 5+8=__13__ + 8+1=9 + --- +-------+---------------+------+---------------+-----------------+ --- + 3 + 9 + 3 + 9+3=__12__ + 3+1=4 (ignored) | --- +-------+---------------+------+---------------+-----------------+ +-- +-------+---------------+------+-----------------+---------------+ +-- + Call + Initial State + Item + New State + Injection + +-- +=======+===============+======+=================+===============+ +-- + 1 + 17 + 4 + 4+1=5 + 17+4=__21__ + +-- +-------+---------------+------+-----------------+---------------+ +-- + 2 + 5 + 8 + 8+1=9 + 5+8=__13__ + +-- +-------+---------------+------+-----------------+---------------+ +-- + 3 + 9 + 3 + 3+1=4 (ignored) | 9+3=__12__ + +-- +-------+---------------+------+-----------------+---------------+ -- -- >>> mapWith ((\_ i -> i) <-^ funnyInjector) [4,8,3] -- [13,12,20] -- --- +-------+---------------+------+---------------+-----------------+ --- + Call + Initial State + Item + Injection + New State + --- +=======+===============+======+===============+=================+ --- + 1 + 17 + 3 + 17+3=__20__ + 3+1=4 + --- +-------+---------------+------+---------------+-----------------+ --- + 2 + 4 + 8 + 4+8=__12__ + 8+1=9 + --- +-------+---------------+------+---------------+-----------------+ --- + 3 + 9 + 4 + 9+4=__13__ + 4+1=5 (ignored) | --- +-------+---------------+------+---------------+-----------------+ +-- +-------+---------------+------+-----------------+---------------+ +-- + Call + Initial State + Item + New State + Injection + +-- +=======+===============+======+=================+===============+ +-- + 1 + 17 + 3 + 3+1=4 + 17+3=__20__ + +-- +-------+---------------+------+-----------------+---------------+ +-- + 2 + 4 + 8 + 8+1=9 + 4+8=__12__ + +-- +-------+---------------+------+-----------------+---------------+ +-- + 3 + 9 + 4 + 4+1=5 (ignored) | 9+4=__13__ + +-- +-------+---------------+------+-----------------+---------------+ -- --- More usefully, this would allow for e.g. the prior two elements: +-- More usefully, this might allow for e.g. injection of random values, etc. + +-- $StackedTupleHelpers +-- These make it easier to define 'Injector' types and injection values. For example: -- --- > prev2Inj = Injector (\x i@(prev1May, prev2May) -> (i, (Just x, prev1May))) (Nothing, Nothing) +-- >>> myInj = Injector (\_ _ -> ((), app3 7 False 'z')) () :: Injector a (App3 Int Bool Char) -- --- or random values, etc. +-- defines an 'Injector', that can map over a 'Traversable' containing any type, and inject three additional constant parameters: @7::Int@, @False::Bool@ and @\'z\'::Char@. Then: +-- +-- >>> mapWith ((,,,) ^-> myInj) ["foo", "bar", "baz"] +-- [("foo",7,False,'z'),("bar",7,False,'z'),("baz",7,False,'z')] +-- +-- You are advised to use these since I'm considering re-working CurryTF so that it's not based on tuples. +-- If I do, I intend to maintain compatibility of app1/App1, etc. +{-# INLINE injPair #-} injPair :: Injector a i1 -> Injector a i2 -> Injector a (i1, i2) injPair (Injector n1 z1) (Injector n2 z2) = Injector nxt (z1, z2) where - nxt a ~(s1, s2) = let (i1, s1') = n1 a s1 -- !! NOTE THE ~ !! It allows "constant" injectors (e.g. isLim), and hence e.g. andFirstLast to work on infinite lists. - (i2, s2') = n2 a s2 - in ((i1, i2), (s1', s2')) + nxt a ~(s1, s2) = let (s1', i1) = n1 a s1 -- !! NOTE THE ~ !! It allows "constant" injectors (e.g. isLim), and hence e.g. andFirstLast to work on infinite lists. + (s2', i2) = n2 a s2 + in ((s1', s2'), (i1, i2)) -- $PredefinedInjectors --- Use these (or custom 'Injector's) to create 'InjectedFn's that can be used with 'mapWith' +-- +-- #PredefinedInjectors#Use these (or custom 'Injector's) to create 'InjectedFn's that can be used with 'mapWith' -isLim :: Injector a Bool -isLim = Injector (\_ i -> (i, False)) True +{-# INLINABLE isLim #-} +isLim :: Injector a (App1 Bool) +isLim = Injector (\_ i -> (False, app1 i)) True -- ^ inject 'True' if the item is at the limit: -- -- - from the left: if it's the first item -- - from the right: if it's the last item -- -- else inject False. +-- +-- >>> let f a l = [a, if l then '*' else ' '] in mapWith (f ^-> isLim) "12345" +-- ["1*","2 ","3 ","4 ","5 "] +-- >>> let f a l = [a, if l then '*' else ' '] in mapWith (f <-^ isLim) "12345" +-- ["1 ","2 ","3 ","4 ","5*"] -eltIx :: Integral i => Injector a i -eltIx = Injector (\_ i -> (i, i+1)) 0 +{-# INLINABLE eltIx #-} +eltIx :: Integral i => Injector a (App1 i) +eltIx = Injector (\_ i -> (i+1, app1 i)) 0 -- ^ inject the item index: -- -- - from the left: the first item is 0, the second 1, etc. -- - from the right: the last item is 0, the penultimate 1, etc. +-- +-- >>> let f a b = a : show b in mapWith (f ^-> eltIx) "freddy" +-- ["f0","r1","e2","d3","d4","y5"] +-- >>> let f a b = a : show b in mapWith (f <-^ eltIx) "freddy" +-- ["f5","r4","e3","d2","d1","y0"] -eltFrom :: Foldable f - => f i -- ^ The elements to inject. There must be enough elements. - -> Injector a i -eltFrom f = Injector (\_ s -> assert (not $ null s) (head s, tail s)) (toList f) +evenElt :: Injector a (App1 Bool) +evenElt = Injector (\_ s -> (not s, app1 s)) True +-- ^ True if an even-numbered (0th, 2nd, 4th, etc) item, counting from the left or from the right. +-- +-- >>> let f a e = [a, if e then '*' else ' '] in mapWith (f ^-> evenElt) "012345" +-- ["0*","1 ","2*","3 ","4*","5 "] +-- >>> let f a e = [a, if e then '*' else ' '] in mapWith (f <-^ evenElt) "543210" +-- ["5 ","4*","3 ","2*","1 ","0*"] + +{-# INLINABLE eltFrom #-} +eltFrom :: [i] -- ^ The elements to inject. There must be enough elements. + -> Injector a (App1 i) +eltFrom l = Injector (\_ s -> assert (not $ null s) (tail s, app1 $ head s)) l -- ^ Inject each given element in turn: -- -- - from the left: the first element will be injected for the first item in the 'Traversable'. -- - from the right: the first element will be injected for the last item in the 'Traversable'. -- +-- >>> let f a b = [a,b] in mapWith (f ^-> eltFrom "bill") "sue" +-- ["sb","ui","el"] +-- >>> let f a b = [a,b] in mapWith (f <-^ eltFrom "bill") "sue" +-- ["sl","ui","eb"] +-- -- As a result of laziness, it is not always an error if there are not enough elements, for example: -- -- >>> drop 1 $ mapWith ((\_ i -> i) <-^ eltFrom [8,2]) "abc" -- [2,8] -eltFromMay :: Foldable f => f i -> Injector a (Maybe i) -eltFromMay f = Injector (\_ s -> case s of [] -> (Nothing, []) - (sh:st) -> (Just sh, st)) - (toList f) +{-# INLINABLE eltFromMay #-} +eltFromMay :: [i] -> Injector a (App1 (Maybe i)) +eltFromMay l = Injector (\_ s -> case s of [] -> ([], app1 Nothing) + i:ix -> (ix, app1 $ Just i)) + l -- ^ a safe version of `eltFrom`. Injects 'Just' each given element in turn, or 'Nothing' after they've been exhausted. +-- +-- >>> let f a b = [a,ch b]; ch = maybe '-' id in mapWith (f ^-> eltFromMay "ben") "sally" +-- ["sb","ae","ln","l-","y-"] +-- >>> let f a b = [a,ch b]; ch = maybe '-' id in mapWith (f <-^ eltFromMay "ben") "sally" +-- ["s-","a-","ln","le","yb"] -eltFromDef :: Foldable f => i -> f i -> Injector a i -eltFromDef def f = Injector (\_ s -> case s of [] -> (def, []) - (sh:st) -> (sh, st)) - (toList f) +{-# INLINABLE eltFromDef #-} +eltFromDef :: i -> [i] -> Injector a (App1 i) +eltFromDef def l = Injector (\_ s -> case s of [] -> ([], app1 def) + i:ix -> (ix, app1 i)) + l -- ^ a safe version of `eltFrom`. Injects each given element in turn, or the default after they've been exhausted. +-- +-- >>> let f a b = [a,b] in mapWith (f ^-> eltFromDef 'X' "ben") "sally" +-- ["sb","ae","ln","lX","yX"] +-- >>> let f a b = [a,b] in mapWith (f <-^ eltFromDef 'X' "ben") "sally" +-- ["sX","aX","ln","le","yb"] -adjElt :: Injector a (Maybe a) -adjElt = Injector (\a prevMay -> (prevMay, Just a)) Nothing +{-# INLINABLE adjElt #-} +adjElt :: Injector a (App1 (Maybe a)) +adjElt = Injector (\a prevMay -> (Just a, app1 prevMay)) Nothing -- ^ inject 'Just' the adjacent item: -- -- - from the left: the previous item, except for the first item -- - from the right: the next item, except for the last item. (The "previous from the right" is the "next".) -- -- inject 'Nothing' if there is no adjacent item (i.e. for the first / last). +-- +-- >>> let f a b = [a,maybe '-' id b] in mapWith (f ^-> adjElt) "12345" +-- ["1-","21","32","43","54"] +-- >>> let f a b = [a,maybe '-' id b] in mapWith (f <-^ adjElt) "12345" +-- ["12","23","34","45","5-"] +{-# INLINABLE adj2Elts #-} +adj2Elts :: Injector a (App2 (Maybe a) (Maybe a)) +adj2Elts = Injector (\a (prev1May, prev2May) -> ((Just a, prev1May), app2 prev1May prev2May)) (Nothing, Nothing) +-- ^ like 'adjElt', but injects the two adjacent items into separate parameters. +-- +-- >>> let f a b c = [a,ch b,ch c]; ch = maybe '-' id in mapWith (f ^-> adj2Elts) "12345" +-- ["1--","21-","321","432","543"] +-- >>> let f a b c = [a,ch b,ch c]; ch = maybe '-' id in mapWith (f <-^ adj2Elts) "12345" +-- ["123","234","345","45-","5--"] + +{-# INLINABLE foldlElts #-} +foldlElts :: (i -> a -> i) + -> i + -> Injector a (App1 i) +foldlElts f z = Injector (\a s -> let s' = f s a in (s', app1 s')) z +-- ^ Inject a (left-associative) fold of the items: +-- +-- +------+---------------------------------------------------------------------------------------------+ +-- | | Injected Value | +-- | +---------------------------------------------+-----------------------------------------------+ +-- | Item | from the left | from the right | +-- +======+=============================================+===============================================+ +-- | a0 | @z \`acc\` a0@ | @((z \`acc\` an) \`acc\` .. a1) \`acc\` a0@ | +-- +------+---------------------------------------------+-----------------------------------------------+ +-- | a1 | @(z \`acc\` a0) \`acc\` a1@ | @(z \`acc\` an) \`acc\` .. a1@ | +-- +------+---------------------------------------------+-----------------------------------------------+ +-- | .. | | | +-- +------+---------------------------------------------+-----------------------------------------------+ +-- | an | @((z \`acc\` a0) \`acc\` a1) \`acc\` .. an@ | @z \`acc\` an@ | +-- +------+---------------------------------------------+-----------------------------------------------+ +-- +-- >>> let f a b = a ++ show b in mapWith (f ^-> foldlElts (\l s -> l + length s) 0) ["every", "good", "boy"] +-- ["every5","good9","boy12"] +-- >>> let f a b = a ++ show b in mapWith (f <-^ foldlElts (\l s -> l + length s) 0) ["every", "good", "boy"] +-- ["every12","good7","boy3"] + +{-# INLINABLE foldl1Elts #-} +foldl1Elts :: (a -> a -> a) + -> Injector a (App1 a) +foldl1Elts f = Injector (\a s -> let s' = maybe a (flip f a) s in (Just s', app1 s')) Nothing +-- ^ A variant of 'foldlElts' that has no starting value: +-- +-- +------+----------------------------------------------------------------------+ +-- | | Injected Value | +-- | +----------------------------------+-----------------------------------+ +-- | Item | from the left | from the right | +-- +======+==================================+===================================+ +-- | a0 | @a0@ | @(an \`acc\` .. a1) \`acc\` a0@ | +-- +------+----------------------------------+-----------------------------------+ +-- | a1 | @a0 \`acc\` a1@ | @an \`acc\` .. a1@ | +-- +------+----------------------------------+-----------------------------------+ +-- | .. | | | +-- +------+----------------------------------+-----------------------------------+ +-- | an | @(a0 \`acc\` a1) \`acc\` .. an@ | @an@ | +-- +------+----------------------------------+-----------------------------------+ +-- +-- >>> mapWith ((,) ^-> foldl1Elts (-)) [10,1,3] +-- [(10,10),(1,9),(3,6)] +-- >>> mapWith ((,) <-^ foldl1Elts (-)) [10,1,3] +-- [(10,-8),(1,2),(3,3)] + -- $CustomMaps -- --- In general, a map function will take one parameter from the 'Traversable', then one each from any number of 'Injector's. For example: +-- In general, a map function will take one parameter from the 'Traversable', then one (or more) from each of any number of 'Injector's. For example: -- -- >>> mapFn w x y z = (w, x, y, z) -- >>> injectedFn = mapFn <-^ isLim ^-> eltIx <-^ eltFrom [8,2,7,1] @@ -216,23 +366,22 @@ -- | 3 | \'c\' | 'True' | 2 | 8 | -- +------+--------+---------+---------+---------+ +{-# INLINABLE mapWith #-} mapWith :: Traversable t => InjectedFn a b -> t a -> t b -mapWith (InjectedFnL f (Injector gen z)) = snd . mapAccumL acc z - where acc s a = let (i, s') = gen a s in (s', f a i) +mapWith (InjectedFnL f (Injector gen z)) = mySnd . myMapAccumL acc z + where acc s a = let (s', i) = gen a s in (s', f a i) mapWith (InjectedFnR f (Injector gen z)) = snd . mapAccumR acc z - where acc s a = let (i, s') = gen a s in (s', f a i) -mapWith (InjectedFnLR f (Injector genL zL) (Injector genR zR)) = snd . mapAccumR accR zR . snd . mapAccumL accL zL - where accL s a = let (i, s') = genL a s in (s', (a, f a i)) - accR s (a, fal) = let (i, s') = genR a s in (s', fal i ) -{- ---This may be clever, but actually slower, and the generation of the (a,f) tuples above doesn't seem to add much time/heap. -mapWith (InjectedFnLR f (Injector genL zL) (Injector genR zR)) = snd . mapAccumR accR zR . snd . mapAccumL accL zL - where accL sl a = let (l, sl') = genL a sl in (sl', \sr -> let (r, sr') = genR a sr in (sr', f a l r)) - accR sr fsr = fsr sr --} + where acc s a = let (s', i) = gen a s in (s', f a i) +mapWith (InjectedFnLR f (Injector genL zL) (Injector genR zR)) = snd . mapAccumR accR zR . mySnd . myMapAccumL accL zL + --have mapAccumL create values (not parial function applications). It can fuse with data providers + --the myMapAccumR can then PIN the mapAccumL results (not on stack) plus its own R-based injections. + --(good) consumets can tail recurse/loop over the data applying the injections as they go. + --(Don't store data or partial functions during recusion unwind: it can cause very slow behaviour on huge lists). + where accL s a = let (s', il) = genL a s in (s', (a, il)) + accR s (a, il) = let (s', ir) = genR a s in (s', f a il ir) -- ^ maps an 'InjectedFn' over a 'Traversable' type @t@, turning a @t a@ into a @t b@ and preserving the structure of @t@. -- -- Parameters (as defined in the 'InjectedFn') are passed to a map function (embedded in the 'InjectedFn'), in addition to the elements of the 'Traversable'. @@ -269,37 +418,42 @@ -- - each @/op/@ is '^->' or '<-^'; and -- - each @/inj/@ is an 'Injector' -- --- produces an @'InjectedFn' a b@, with n injected values. +-- produces an @'InjectedFn' a b@, with n injected values (or more if any of the injectors inject multiple values). class Injectable m where -- | Inject "from the left" - (^->) :: (m a (i -> b)) -> Injector a i -> InjectedFn a b + (^->) :: CurryTF i b => m a (FnType i b) -> Injector a i -> InjectedFn a b -- | Inject "from the right" - (<-^) :: (m a (i -> b)) -> Injector a i -> InjectedFn a b + (<-^) :: CurryTF i b => m a (FnType i b) -> Injector a i -> InjectedFn a b -- ^ An 'Injectable' is (recursively) either: -- --- - a function @(a -> i -> b)@; or --- - an @InjectedFn a (i -> b)@, created by @'Injectable' /op/ 'Injector'@ +-- - a function @(a -> i1 [.. -> in] -> b)@; or +-- - an @InjectedFn a (i1 [.. -> in] -> b)@, created by @'Injectable' /op/ 'Injector'@ +-- +-- When @n@ is the number of parameters injected by an injector (most commonly 1). + infixl 1 ^-> infixl 1 <-^ +--In the below, iL = existing left Injector; nL = new left Injector. l = existing left-injected value; nl = new left-injected value. + instance Injectable (->) where - f ^-> itL' = InjectedFnL (\a l -> f a l) itL' - f <-^ itR' = InjectedFnR (\a r -> f a r) itR' + f ^-> nL = InjectedFnL (\a nl -> f a $# nl) nL + f <-^ nR = InjectedFnR (\a nr -> f a $# nr) nR instance Injectable InjectedFn where - InjectedFnL f itL ^-> itL' = InjectedFnL (\a (l, l') -> f a l l') (injPair itL itL') - InjectedFnR f itR ^-> itL' = InjectedFnLR (\a l' r -> f a r l') itL' itR - InjectedFnLR f itL itR ^-> itL' = InjectedFnLR (\a (l, l') r -> f a l r l') (injPair itL itL') itR + InjectedFnL f iL ^-> nL = InjectedFnL (\a (l, nl) -> f a l $# nl) (injPair iL nL) + InjectedFnR f iR ^-> nL = InjectedFnLR (\a nl r -> f a r $# nl) nL iR + InjectedFnLR f iL iR ^-> nL = InjectedFnLR (\a (l, nl) r -> f a l r $# nl) (injPair iL nL) iR - InjectedFnL f itL <-^ itR' = InjectedFnLR (\a l r' -> f a l r') itL itR' - InjectedFnR f itR <-^ itR' = InjectedFnR (\a (r, r') -> f a r r') (injPair itR itR') - InjectedFnLR f itL itR <-^ itR' = InjectedFnLR (\a l (r, r') -> f a l r r') itL (injPair itR itR') + InjectedFnL f iL <-^ nR = InjectedFnLR (\a l nr -> f a l $# nr) iL nR + InjectedFnR f iR <-^ nR = InjectedFnR (\a (r, nr) -> f a r $# nr) (injPair iR nR) + InjectedFnLR f iL iR <-^ nR = InjectedFnLR (\a l (r, nr) -> f a l r $# nr) iL (injPair iR nR) -- $PrecombinedInjectors --- These are combinations of '^->' or '<-^' with 'isLim' or 'adjElt'. +-- These are combinations of '^->' or '<-^' with [pre-defined injectors](#PredefinedInjectors). -- -- They work well with the '&' operator, and can be combined with the '^->' and '<-^' operators e.g.: -- @@ -326,17 +480,36 @@ -- $PrePackagedMaps -- Some pre-defined maps with commonly used injectors. +{-# INLINABLE withFirst #-} +withFirst :: Traversable t => (a -> Bool -> b) -> t a -> t b +withFirst f = mapWith $ f & isFirst +-- ^ Maps over a 'Traversable', with an additional parameter indicating whether an item is the first. +-- +-- >>> let g x f = [if f then '*' else ' ', x] in withFirst g "fred" +-- ["*f", " r", " e", " d"] + +{-# INLINABLE withLast #-} +withLast :: Traversable t => (a -> Bool -> b) -> t a -> t b +withLast f = mapWith $ f & isLast +-- ^ Maps over a 'Traversable', with an additional parameter indicating whether an item is the last. +-- +-- >>> let g x l = [x, if l then '*' else ' '] in withLast g "fred" +-- ["f ","r ","e ","d*"] + +{-# INLINABLE withFirstLast #-} withFirstLast :: Traversable t => (a -> Bool -> Bool -> b) -> t a -> t b withFirstLast f = mapWith $ f & isFirst & isLast --- ^ Maps over a 'Traversable', with additional parameters indicating whether an item is the first or last (or both) in the list. +-- ^ Maps over a 'Traversable', with additional parameters indicating whether an item is the first or last (or both). -- --- >>> let f x isFirst isLast = star isFirst ++ x ++ star isLast; star b = if b then "*" else "" in withFirstLast f ["foo", "bar", "baz"] --- ["*foo", "bar", "baz*"] +-- >>> let g x f l = [star f, x, star l]; star b = if b then '*' else ' ' in withFirstLast g "fred" +-- ["*f ", " r ", " e ", " d*"] +{-# INLINABLE andFirstLast #-} andFirstLast :: Traversable t => t a -> t (a, Bool, Bool) andFirstLast = withFirstLast (,,) -- ^ > andFirstLast = withFirstLast (,,) +{-# INLINABLE withPrevNext #-} withPrevNext :: Traversable t => (a -> Maybe a -> Maybe a -> b) -> t a -> t b withPrevNext f = mapWith $ f & prevElt & nextElt -- ^ Maps over a 'Traversable', with additional parameters indicating the previous and next elements. @@ -346,6 +519,88 @@ -- >>> let f x prvMay nxtMay = maybe "*" (cmp x) prvMay ++ x ++ maybe "*" (cmp x) nxtMay; cmp x y = show $ compare x y in withPrevNext f ["foo", "bar", "baz"] -- ["*fooGT","LTbarLT","GTbaz*"] +{-# INLINABLE andPrevNext #-} andPrevNext :: Traversable t => t a -> t (a, Maybe a, Maybe a) andPrevNext = withPrevNext (,,) -- ^ > andPrevNext = withPrevNext (,,) + +-- myMapAccumL/R which can fuse. + +{-# NOINLINE [1] myMapAccumL #-} --cf {-# NOINLINE [1] unsafeTake #-} +myMapAccumL :: Traversable t => (s -> a -> (s, b)) -> s -> t a -> (s, t b) +myMapAccumL = mapAccumL + +{-# NOINLINE [1] mySnd #-} +mySnd :: (a, b) -> b +mySnd = snd + +{-# RULES --modelled on "take". +"sndMapAccumL" [~1] forall f z xs. mySnd (myMapAccumL f z xs) = + build (\c nil -> foldr (mapAccumLFB c f) (flipSeqMapAccumL nil) xs z) + #-} + {- + I can't make this fire, but it doesn't seem to be a great loss. +"sndMapAccumLList" [1] forall f z xs. foldr (mapAccumLFB (:) f) (flipSeqMapAccumL []) xs z = + sndMapAccumLList f z xs +{-# NOINLINE [1] sndMapAccumLList #-} +sndMapAccumLList :: (s -> a -> (s, b)) -> s -> [a] -> [b] +sndMapAccumLList f z = snd . mapAccumL f z + -} + +{-# INLINE [0] mapAccumLFB #-} +mapAccumLFB :: (b -> r -> r) -> (s -> a -> (s, b)) -> a -> (s -> r) -> s -> r +mapAccumLFB c f x xs = \s -> let (s', b) = f s x in b `c` xs s' + +{-# INLINE [0] flipSeqMapAccumL #-} +flipSeqMapAccumL :: a -> s -> a +flipSeqMapAccumL x !_s = x + +{- $Performance +I think the performance is now (since 0.2.0.0) excellent. In particular: + +- `mapWith` "traverses" in each direction at most once, and only goes in both directions if it needs to; +- many functions are inlinable and "compile away"; and +- mapWith is capable of fusion (see details below). + +If you have any examples where you think performance is poor, or suggestions for improvements, please let me know. +-} + +{- $Benchmarks +I've compared the performance of `mapWith` vs [markbounds](https://stackoverflow.com/questions/14114011/haskell-map-operation-with-different-first-and-last-functions#answer-53282575) +and a number of other attempts to "hand craft" equivalent functionality. +The results are in [Benchmarks.ods](https://github.com/davjam/MapWith/blob/master/doc/Benchmarks.ods). +The [Benchmarks.hs](https://github.com/davjam/MapWith/blob/master/perf/Benchmarks.hs) file contains the details of these tests. +-} + +{- $Fusion +`mapWith` & friends are capable of [list fusion](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#list-fusion). +When the `Traversable` is a List, `mapWith` is always a "good consumer". When the only injections are "from the left", it is also a "good producer". + +As a result, code like: + +>>> let f n b = if b then n*2 else n*3 in sum $ mapWith (f ^-> evenElt) [1..1000000] + +will compile to a loop with no generation of list elements and no call stack usage. + +When a "from the right" injection occurs, `mapWith` is not a "good producer", and an intermediate list will be created. +However, with a "state free" `Injector` (such as `isLim` or `adjElt`), the list elements will only exist temporarily, the call stack will not grow +(see [here](https://stackoverflow.com/questions/63504127/haskell-pinned-or-stack-memory-for-performance)), +and there is no limit to the number of elements in the processed list. + +With other "from the right" Injectors, the call stack will grow as elements are processed, giving a limit to the size of the list. +Despite this, I think the performance remains very good, and better than many alternative approaches. + +In summary, when `mapWith` sits between a "good producer" and a "good consumer", there are three broad categories of behaviour: + + +-----------------------------------------+--------------+------------+ + | Injections | Speed | Size limit | + +=========================================+==============+============+ + | only "from the left" | exceptional | No | + +-----------------------------------------+--------------+------------+ + | "from the right", but only "state free" | very good | No | + +-----------------------------------------+--------------+------------+ + | any | good | Yes | + +-----------------------------------------+--------------+------------+ + +Note that `eltFrom` (and similar) are not a "good consumers". +-}
+ test/CurryTFTest.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE TypeApplications #-} + +module Main (main) +where + +import System.Exit + +import CurryTF + +main | and tests = exitSuccess + | otherwise = exitFailure + +tests = [ zC == 3081 + , zU == 3081 + , fn1 ('x', (3, (True, ()))) == (uncurryN . curryN) fn1 ('x', (3, (True, ()))) + , fn2 'y' 2 False == (curryN . uncurryN @(Char, (Int, (Bool, ()))) @String) fn2 'y' 2 False + ] + +fn1 (c, (n, (b, ()))) = c : replicate n '1' ++ if b then "hello" else "goodbye" + +fn2 c n b = c : replicate n '2' ++ if b then "hello" else "goodbye" + +xC a b c d e f g h i j k l m n o p q r s t u v w x y z + a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1 l1 m1 n1 o1 p1 q1 r1 s1 t1 u1 v1 w1 x1 y1 z1 + a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2 m2 n2 o2 p2 q2 r2 s2 t2 u2 v2 w2 x2 y2 z2 + = a +b +c +d +e +f +g +h +i +j +k +l +m +n +o +p +q +r +s +t +u +v +w +x +y +z + + a1+b1+c1+d1+e1+f1+g1+h1+i1+j1+k1+l1+m1+n1+o1+p1+q1+r1+s1+t1+u1+v1+w1+x1+y1+z1 + + a2+b2+c2+d2+e2+f2+g2+h2+i2+j2+k2+l2+m2+n2+o2+p2+q2+r2+s2+t2+u2+v2+w2+x2+y2+z2 + +zC = xC $# (1 , (2 , (3 , (4 , (5 , (6 , (7 , (8 , (9 , (10, (11, (12, (13, (14, (15, (16, (17, (18, (19, (20, (21, (22, (23, (24, (25, (26, + (27, (28, (29, (30, (31, (32, (33, (34, (35, (36, (37, (38, (39, (40, (41, (42, (43, (44, (45, (46, (47, (48, (49, (50, (51, (52, + (53, (54, (55, (56, (57, (58, (59, (60, (61, (62, (63, (64, (65, (66, (67, (68, (69, (70, (71, (72, (73, (74, (75, (76, (77, (78, + ())))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + +xU (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, (m, (n, (o, (p, (q, (r, (s, (t, (u, (v, (w, (x, (y, (z, + (a1,(b1,(c1,(d1,(e1,(f1,(g1,(h1,(i1,(j1,(k1,(l1,(m1,(n1,(o1,(p1,(q1,(r1,(s1,(t1,(u1,(v1,(w1,(x1,(y1,(z1, + (a2,(b2,(c2,(d2,(e2,(f2,(g2,(h2,(i2,(j2,(k2,(l2,(m2,(n2,(o2,(p2,(q2,(r2,(s2,(t2,(u2,(v2,(w2,(x2,(y2,(z2, + ())))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + = a +b +c +d +e +f +g +h +i +j +k +l +m +n +o +p +q +r +s +t +u +v +w +x +y +z + + a1+b1+c1+d1+e1+f1+g1+h1+i1+j1+k1+l1+m1+n1+o1+p1+q1+r1+s1+t1+u1+v1+w1+x1+y1+z1 + + a2+b2+c2+d2+e2+f2+g2+h2+i2+j2+k2+l2+m2+n2+o2+p2+q2+r2+s2+t2+u2+v2+w2+x2+y2+z2 + +zU = curryN xU 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 + 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 + 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 + + + +
test/MapWithTest.hs view
@@ -2,8 +2,12 @@ {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} +module Main (main) +where + import System.Exit import Data.Function ((&)) +import Data.List.NonEmpty (NonEmpty(..), fromList) import MapWith testFn0 :: a -> b -> b @@ -31,6 +35,9 @@ data FunnySet a = FunnySet a a a a a deriving (Eq, Show, Functor, Foldable, Traversable) +sillyInj :: Injector Int (App1 Int) --testing we've exported enough to make building Injectors easy. +sillyInj = Injector (\a s -> (s+2, app1 (a+s))) 3 + tests :: [Bool] tests = [ @@ -41,17 +48,30 @@ , mapWith (testFn0 & prevElt) "abc" == [Nothing, Just 'a', Just 'b'] , mapWith (testFn0 & nextElt) "abc" == [Just 'b', Just 'c', Nothing] , andFirstLast "abc" == [('a',True,False),('b',False,False),('c',False,True)] + , andFirstLast "a" == [('a',True,True)] + , andFirstLast "" == [] , take 3 (andFirstLast [1..]) == [(1,True,False),(2,False,False),(3,False,False)] , andFirstLast (FunnySet 8 9 1 2 5) == FunnySet (8,True,False) (9,False,False) (1,False,False) (2,False,False) (5,False,True) , mapWith (testFn0 <-^ eltFromMay [1,2]) [1,2,3] == [Nothing, Just 2, Just 1] , mapWith (testFn0 <-^ eltFromDef 7 [1,2]) [1,2,3] == [7, 2, 1] - + , mapWith (testFn0 ^-> evenElt) "abcdef" == [True,False,True,False,True,False] + , mapWith (testFn0 <-^ evenElt) "abcdef" == [False,True,False,True,False,True] + , mapWith (testFn0 ^-> foldl1Elts (-) ) [9, 1, 8] == [ 9, 8, 0] + , mapWith (testFn0 <-^ foldl1Elts (-) ) [9, 1, 8] == [-2, 7, 8] + , mapWith (testFn0 ^-> foldlElts (-) 20) [9, 1, 8] == [11, 10, 2] + , mapWith ((,,,) ^-> adj2Elts & isLast) "fred" ==[('f',Nothing,Nothing,False),('r',Just 'f',Nothing,False),('e',Just 'r',Just 'f',False),('d',Just 'e',Just 'r',True)] + , mapWith (testFn0 ^-> sillyInj) [4, 5, 6] == [7,10,13] +--, length (scoreWeek [1,2..168]) == 168 --hangs in GHC 8.4.3 (per https://gitlab.haskell.org/ghc/ghc/-/issues/16943) + , length (mapWeek [1,2..168]) == 168 --I don't think we have quite the same situation, and I think I've tested lots of infinite list cases already, but trying to be safe. ] -main = do - if and tests - then exitSuccess - else exitFailure +main | and tests = exitSuccess + | otherwise = exitFailure +scoreWeek :: [Int] -> [[Int]] +scoreWeek xs = take 168 $ scanr (:) [] $ cycle xs + +mapWeek :: [Int] -> [Int] +mapWeek xs = take 168 $ mapWith (testFn0 ^-> eltIx) $ cycle xs