Reimplementation of Haskell’s "Data.Foldable.Foldable" from "Prelude" in order to fix partial functions.

TotalFoldable.hs

#! /usr/bin/env nix-shell
#! nix-shell -i runhaskell -E
#! nix-shell "let ghc=n.haskellPackages.ghcWithPackages(p:[p.hspec]); n=import(fetchTarball{url=\"https://github.com/NixOS/nixpkgs/archive/db31e48c5c8d99dcaf4e5883a96181f6ac4ad6f6.tar.gz\";sha256=\"1j5j7vbnq2i5zyl8498xrf490jca488iw6hylna3lfwji6rlcaqr\";}){}; in n.mkShell{buildInputs=[ghc];}"

-- Reimplementation of Haskell’s "Data.Foldable.Foldable" from "Prelude" in order to fix partial
-- functions.
--
-- Author: Viacheslav Lotsmanov, 2020
--
-- Still WIP, planning to make a library as soon as it implements all the required stuff.
-- See comments for "TotalFoldable" for details.

{-# OPTIONS_GHC -Wall -Wno-missing-signatures #-}
{-# LANGUAGE UnicodeSyntax, PolyKinds, TypeFamilies, FlexibleInstances, ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses, NoMonomorphismRestriction, LambdaCase #-}

import Prelude hiding (Foldable (..))

import Data.Kind (Type)
import Data.List.NonEmpty
import qualified Data.Foldable

import Test.Hspec
import Test.QuickCheck (property)

-- | It supposed to solve the problem with "Data.Foldable.Foldable" typeclass.
--
-- The problem with "Data.Foldable.Foldable" is that for "Monoid"s (I’m not sure if I’m
-- theoretically correct here, I mean for “empty entities” such as empty lists) it has partial
-- functions such as "Data.Foldable.Foldable.foldl1" or "Data.Foldable.Foldable.foldr1".
--
-- Consider @Data.Foldable.Foldable []@ instance, if you try to run
-- @foldl1 (+) (mempty ∷ [Int])@ you’ll end up with this runtime exception:
-- @Prelude.foldl1: empty list@.
--
-- This type class copies @Data.Foldable.Foldable@ but for types which may have “empty state” you can
-- redefine return type, so you could wrap it with @Maybe@ thus making such functions be total.
--
-- Names of the functions from this type class are clashing with ones from "Data.Foldable.Foldable"
-- so you’re supposed to “hide” those from "Prelude" first:
--
-- @
-- import Prelude hiding (Foldable (..))
-- @
class TotalFoldable (t ∷ Type → Type) (a ∷ Type) where
  -- TODO implement
  -- {-# MINIMAL foldMap | foldr #-}

  -- | Either just a value or a value wrapped in @Maybe@.
  --
  -- So either @Type@ or @Type → Type@ (that’s why it’s poly-kinded).
  type Fold1Return t a ∷ polykind

  -- TODO implement
  -- fold :: Monoid m => t m -> m
  -- fold = foldMap id

  -- TODO implement
  -- foldMap :: Monoid m => (a -> m) -> t a -> m
  -- {-# INLINE foldMap #-}
  -- -- This INLINE allows more list functions to fuse. See Trac #9848.
  -- foldMap f = foldr (mappend . f) mempty

  -- TODO implement
  -- foldMap' :: Monoid m => (a -> m) -> t a -> m
  -- foldMap' f = foldl' (\ acc a -> acc <> f a) mempty

  -- TODO implement
  -- foldr :: (a -> b -> b) -> b -> t a -> b
  -- foldr f z t = appEndo (foldMap (Endo #. f) t) z

  -- TODO implement
  -- foldr' :: (a -> b -> b) -> b -> t a -> b
  -- foldr' f z0 xs = foldl f' id xs z0
  --   where f' k x z = k $! f x z

  -- TODO provide default implementation
  -- foldl :: (b -> a -> b) -> b -> t a -> b
  -- foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z
  foldl ∷ (acc → a → acc) → acc → t a → acc

  -- TODO implement
  -- foldl' :: (b -> a -> b) -> b -> t a -> b
  -- foldl' f z0 xs = foldr f' id xs z0
  --   where f' x k z = k $! f z x

  -- TODO implement
  -- foldr1 :: (a -> a -> a) -> t a -> a
  -- foldr1 f xs = fromMaybe (errorWithoutStackTrace "foldr1: empty structure")
  --                 (foldr mf Nothing xs)
  --   where
  --     mf x m = Just (case m of
  --                      Nothing -> x
  --                      Just y  -> f x y)

  -- foldl1 :: (a -> a -> a) -> t a -> a
  -- foldl1 f xs = fromMaybe (errorWithoutStackTrace "foldl1: empty structure")
  --                 (foldl mf Nothing xs)
  --   where
  --     mf m y = Just (case m of
  --                      Nothing -> y
  --                      Just x  -> f x y)
  foldl1 ∷ (a → a → a) → t a → Fold1Return t a

  -- TODO implement
  -- toList :: t a -> [a]
  -- {-# INLINE toList #-}
  -- toList t = build (\ c n -> foldr c n t)

  -- TODO implement
  -- null :: t a -> Bool
  -- null = foldr (\_ _ -> False) True

  -- TODO implement
  -- length :: t a -> Int
  -- length = foldl' (\c _ -> c+1) 0

  -- TODO implement
  -- elem :: Eq a => a -> t a -> Bool
  -- elem = any . (==)

  -- TODO implement
  -- maximum :: forall a . Ord a => t a -> a
  -- maximum = fromMaybe (errorWithoutStackTrace "maximum: empty structure") .
  --    getMax . foldMap (Max #. (Just :: a -> Maybe a))

  -- TODO implement
  -- minimum :: forall a . Ord a => t a -> a
  -- minimum = fromMaybe (errorWithoutStackTrace "minimum: empty structure") .
  --    getMin . foldMap (Min #. (Just :: a -> Maybe a))

  -- TODO implement
  -- sum :: Num a => t a -> a
  -- sum = getSum #. foldMap Sum

  -- TODO implement
  -- product :: Num a => t a -> a
  -- product = getProduct #. foldMap Product

instance TotalFoldable [] a where
  type Fold1Return [] a = Maybe a

  foldl _ acc []       = acc
  foldl f acc (x : xs) = foldl f (f acc x) xs

  foldl1 _ [ ]          = Nothing
  foldl1 _ [x]          = Just x
  foldl1 f (x : y : ys) = foldl1 f (f x y : ys)

instance TotalFoldable NonEmpty a where
  type Fold1Return NonEmpty a = a

  foldl f acc (x :| [])     = f acc x
  foldl f acc (x :| y : ys) = foldl f (f acc x) (y :| ys)

  foldl1 _ (x :| [])     = x
  foldl1 f (x :| y : ys) = foldl1 f (f x y :| ys)


main ∷ IO ()
main = hspec $ do
  let
    shower acc x = acc ⋄ "|" ⋄ show x
    f a b = a - 10 - b

  describe "[]" $ do
    describe "foldl" $ do
      it "Integer" $ do
        foldl shower mempty ([] ∷ [Integer])              `shouldBe` ""
        foldl shower mempty ([100] ∷ [Integer])           `shouldBe` "|100"
        foldl shower mempty ([100, 200] ∷ [Integer])      `shouldBe` "|100|200"
        foldl shower mempty ([100, 200, 300] ∷ [Integer]) `shouldBe` "|100|200|300"

      it "Word" $ do
        foldl shower mempty ([] ∷ [Word])              `shouldBe` ""
        foldl shower mempty ([100] ∷ [Word])           `shouldBe` "|100"
        foldl shower mempty ([100, 200] ∷ [Word])      `shouldBe` "|100|200"
        foldl shower mempty ([100, 200, 300] ∷ [Word]) `shouldBe` "|100|200|300"

      describe "Complies with Data.Foldable" $ do
        it "Integer" $ property $ \(xs ∷ [Integer]) →
          foldl shower "" xs == Data.Foldable.foldl shower "" xs
        it "Word" $ property $ \(xs ∷ [Word]) →
          foldl shower "" xs == Data.Foldable.foldl shower "" xs

    describe "foldl1" $ do
      it "Integer" $ do
        foldl1 f ([] ∷ [Integer])              `shouldBe` Nothing
        foldl1 f ([500] ∷ [Integer])           `shouldBe` Just 500
        foldl1 f ([500, 200] ∷ [Integer])      `shouldBe` Just 290
        foldl1 f ([500, 200, 100] ∷ [Integer]) `shouldBe` Just 180

      it "Word" $ do
        foldl1 f ([] ∷ [Word])              `shouldBe` Nothing
        foldl1 f ([500] ∷ [Word])           `shouldBe` Just 500
        foldl1 f ([500, 200] ∷ [Word])      `shouldBe` Just 290
        foldl1 f ([500, 200, 100] ∷ [Word]) `shouldBe` Just 180

      describe "Complies with Data.Foldable" $ do
        it "Integer" $ property $ \case
          [] → True -- "Data.Foldable.foldl1" throws exception on an empty list
          (xs ∷ [Integer]) → foldl1 f xs == Just (Data.Foldable.foldl1 f xs)

        it "Word" $ property $ \case
          [] → True -- "Data.Foldable.foldl1" throws exception on an empty list
          (xs ∷ [Word]) → foldl1 f xs == Just (Data.Foldable.foldl1 f xs)

  describe "NonEmpty" $ do
    describe "foldl" $ do
      it "Integer" $ do
        foldl shower mempty (100 :| [] ∷ NonEmpty Integer)         `shouldBe` "|100"
        foldl shower mempty (100 :| [200] ∷ NonEmpty Integer)      `shouldBe` "|100|200"
        foldl shower mempty (100 :| [200, 300] ∷ NonEmpty Integer) `shouldBe` "|100|200|300"

      it "Word" $ do
        foldl shower mempty (100 :| [] ∷ NonEmpty Word)         `shouldBe` "|100"
        foldl shower mempty (100 :| [200] ∷ NonEmpty Word)      `shouldBe` "|100|200"
        foldl shower mempty (100 :| [200, 300] ∷ NonEmpty Word) `shouldBe` "|100|200|300"

      describe "Complies with Data.Foldable" $ do
        it "Integer" $ property $ \case
          [] → True -- Not appliable for NonEmpty
          (x : xs ∷ [Integer]) →
            foldl shower "" (x :| xs) == Data.Foldable.foldl shower "" (x :| xs)
        it "Word" $ property $ \case
          [] → True -- Not appliable for NonEmpty
          (x : xs ∷ [Word]) → foldl shower "" (x :| xs) == Data.Foldable.foldl shower "" (x :| xs)

    describe "foldl1" $ do
      it "Integer" $ do
        foldl1 f (500 :| [] ∷ NonEmpty Integer)         `shouldBe` 500
        foldl1 f (500 :| [200] ∷ NonEmpty Integer)      `shouldBe` 290
        foldl1 f (500 :| [200, 100] ∷ NonEmpty Integer) `shouldBe` 180

      it "Word" $ do
        foldl1 f (500 :| [] ∷ NonEmpty Word)         `shouldBe` 500
        foldl1 f (500 :| [200] ∷ NonEmpty Word)      `shouldBe` 290
        foldl1 f (500 :| [200, 100] ∷ NonEmpty Word) `shouldBe` 180

      describe "Complies with Data.Foldable" $ do
        it "Integer" $ property $ \case
          [] → True -- Not appliable for NonEmpty
          (x : xs ∷ [Integer]) → foldl1 f (x :| xs) == Data.Foldable.foldl1 f (x :| xs)
        it "Word" $ property $ \case
          [] → True -- Not appliable for NonEmpty
          (x : xs ∷ [Word]) → foldl1 f (x :| xs) == Data.Foldable.foldl1 f (x :| xs)

(⋄) = (<>)
-- vim: se et ts=2 sts=2 sw=2 tw=100 cc=+1 :