Added 'force-elems'

Author: effectfully

force-elems/LICENSE

@@ -0,0 +1,30 @@
+Copyright Author name here (c) 2021
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

force-elems/README.md

@@ -0,0 +1,28 @@
+# `forceElems`
+
+The following function "entangles" the elements of a list with its spine, so that whenever the outermost constructor gets forced, the head element also gets forced (unless the list is empty, in which case nothing extra happens):
+
+```haskell
+forceElemsList :: [a] -> [a]
+forceElemsList = foldr ((:) $!) []
+```
+
+Check out [Trouble in paradise: Fibonacci](https://github.com/effectfully/sketches/tree/master/trouble-in-paradise-fibonacci) if you're interested how such a thing can be useful.
+
+Note that `forceElemsList` does not force the spine of its argument, it only ensures that whenever some consumer forces the spine of the list returned by `forceElemsList`, the elements of that list get forced as well.
+
+Can you define a function that does the same, but for any `Traversable`? I.e. a function having the following type signature:
+
+```haskell
+forceElems :: Traversable t => t a -> t a
+```
+
+Rules:
+
+1. just like `forceElemsList`, `forceElems` does not force the spine of its argument (and so can handle infinite structures)
+2. containers having constructors storing multiple elements of type `a` (the order in which those get forces does not matter) and multiple recursive occurrences are allowed, as well as polymorphic recursion
+3. no need to handle weird custom `Traversable` instances that do not agree with `DeriveTraversable`, like `fmap id` calls inserted manually in the middle of a `traverse` definition (although that particular case can be handled)
+
+Replace `forceElems = undefined` in [`src/Lib.hs`](src/Lib.hs) with an actual definition of `forceElems`.
+
+There's a small test suite, which I run with `stack test` (`cabal` should probably work as well, but I haven't checked).

force-elems/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

force-elems/force-elems.cabal

@@ -0,0 +1,34 @@
+name:                force-elems
+version:             0.1.0.0
+-- synopsis:
+-- description:
+homepage:            https://github.com/githubuser/force-elems#readme
+license:             BSD3
+license-file:        LICENSE
+author:              Author name here
+maintainer:          [email protected]
+copyright:           2021 Author name here
+category:            Web
+build-type:          Simple
+extra-source-files:  README.md
+cabal-version:       >=1.10
+
+library
+  hs-source-dirs:      src
+  exposed-modules:     Lib
+  build-depends:       base >= 4.7 && < 5
+  default-language:    Haskell2010
+
+test-suite force-elems-test
+  type: exitcode-stdio-1.0
+  main-is: Main.hs
+  hs-source-dirs: test
+  ghc-options: -O2
+  build-depends: base >=4.7 && <5,
+                 HUnit,
+                 force-elems
+  default-language: Haskell2010
+
+source-repository head
+  type:     git
+  location: https://github.com/githubuser/force-elems

force-elems/src/Lib.hs

@@ -0,0 +1,6 @@
+module Lib
+    ( forceElems
+    ) where
+
+forceElems :: Traversable t => t a -> t a
+forceElems = undefined

force-elems/stack.yaml

@@ -0,0 +1,4 @@
+resolver: lts-16.27
+
+packages:
+- .

force-elems/stack.yaml.lock

@@ -0,0 +1,12 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages: []
+snapshots:
+- completed:
+    size: 533252
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/27.yaml
+    sha256: c2aaae52beeacf6a5727c1010f50e89d03869abfab6d2c2658ade9da8ed50c73
+  original: lts-16.27

force-elems/test/Main.hs

@@ -0,0 +1,92 @@
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE RankNTypes        #-}
+
+module Main where
+
+import           Lib
+
+import           Data.IORef
+import           Data.List
+import           System.IO.Unsafe
+import           Test.HUnit
+
+withTrace :: ((forall b. a -> b -> b) -> c) -> IO ([a], c)
+withTrace k = do
+    xsVar <- newIORef id
+    let z = k $ \x y -> unsafePerformIO $ y <$ modifyIORef xsVar (. (x :))
+    ds <- unsafeInterleaveIO $ readIORef xsVar
+    return (ds [], z)
+
+tracesAndNats :: IO ([Int], [()])
+tracesAndNats =
+    withTrace $ \trace ->
+        let go n = trace n () : go (n + 1)
+        in go 0
+
+data Tree2 a
+    = Fork2 (Tree2 a) a (Tree2 a) a
+    deriving (Functor, Foldable, Traversable)
+
+zigZag :: Tree2 a -> [a]
+zigZag = go False where
+    go False (Fork2 _ x r _) = x : go True  r
+    go True  (Fork2 l _ _ y) = y : go False l
+
+tracesAndPathsTree2 :: IO ([String], Tree2 ())
+tracesAndPathsTree2 =
+    withTrace $ \trace ->
+        let go p =
+              Fork2
+                (go (p . ('l' :)))
+                (trace (p "x") ())
+                (go (p . ('r' :)))
+                (trace (p "y") ())
+        in go id
+
+data Rose a
+    = Rose a [Rose a]
+    deriving (Functor, Foldable, Traversable)
+
+rightmost :: Rose a -> [a]
+rightmost (Rose x rs) = x : if null rs then [] else rightmost $ last rs
+
+tracesAndPathsRose :: IO ([[Int]], Rose ())
+tracesAndPathsRose =
+    withTrace $ \trace ->
+        let go n p =
+              Rose
+                (trace (p []) ())
+                (map (\m -> go (n + 1) (p . (m :))) [0..n])
+        in go 0 id
+
+main :: IO ()
+main = runTestTTAndExit . TestList $ map TestCase
+    [ do
+        (traces, nats) <- tracesAndNats
+        length (take 6 nats) @?= 6
+        traces @?= []
+    , do
+        (traces, nats) <- tracesAndNats
+        length (take 1 $ forceElems nats) @?= 1
+        traces @?= [0]
+    , do
+        (traces, nats) <- tracesAndNats
+        length (take 5 $ forceElems nats) @?= 5
+        traces @?= [0, 1, 2, 3, 4]
+    , do
+        (traces, paths) <- tracesAndPathsTree2
+        length (take 3 $ zigZag paths) @?= 3
+        traces @?= []
+    , do
+        (traces, paths) <- tracesAndPathsTree2
+        length (take 4 . zigZag $ forceElems paths) @?= 4
+        sort traces @?= ["rlrx", "rlry", "rlx", "rly", "rx", "ry", "x", "y"]
+    , do
+        (traces, paths) <- tracesAndPathsRose
+        length (take 2 $ rightmost paths) @?= 2
+        traces @?= []
+    , do
+        (traces, paths) <- tracesAndPathsRose
+        length (take 7 . rightmost $ forceElems paths) @?= 7
+        traces @?= inits [0..5]
+    ]