Learning about recursion schemes

default.nix

let
  nixpkgs = import (fetchTarball {
    url =
      "https://github.com/NixOS/nixpkgs/archive/bed08131cd29a85f19716d9351940bdc34834492.tar.gz";
  }) { };
in nixpkgs.haskellPackages.callPackage
({ mkDerivation, lib, doctest, recursion-schemes }:
  mkDerivation {
    pname = "learning-recursion-schemes";
    version = "0.1.0.0";
    isLibrary = false;
    isExecutable = true;
    testHaskellDepends = [ doctest ];
    executableHaskellDepends = [ recursion-schemes ];
    license = lib.licenses.bsd3;
  }) { }

Main.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

module Main where

import Data.Bifoldable (Bifoldable (bifoldr))
import Data.Bool (bool)
import Data.Foldable (maximumBy, toList)
import Data.Function (on)
import Data.Functor.Foldable (Base, Recursive, cata, para)
import Data.Sequence (Seq, (<|), (|>))
import qualified Data.Sequence as Seq
import GHC.Generics (Generic)

data Tree a = Leaf | Branch (Tree a) a (Tree a) deriving (Generic, Show)

data TreeF a b = LeafF | BranchF b a b deriving (Generic, Functor, Show)

testTree :: Tree Int
testTree =
  Branch
    ( Branch
        ( Branch
            Leaf
            1
            Leaf
        )
        2
        ( Branch
            Leaf
            3
            Leaf
        )
    )
    4
    ( Branch
        Leaf
        5
        Leaf
    )

-- | This let's us write
-- >>> import Data.Bifoldable (bisum, biproduct)
-- >>> cata bisum testTree
-- 15
-- >>> cata biproduct testTree
-- 120
instance Bifoldable TreeF where
  bifoldr :: (a -> c -> c) -> (b -> c -> c) -> c -> TreeF a b -> c
  bifoldr _ _ c LeafF = c
  bifoldr f g c (BranchF l a r) = g l (f a (g r c))

type instance Base (Tree a) = TreeF a

instance Recursive (Tree a)

root :: forall a. Tree a -> Maybe a
root = cata \case
  LeafF -> Nothing
  BranchF _ a _ -> Just a

maybeToSeq :: forall a. Maybe a -> Seq a
maybeToSeq = maybe Seq.empty Seq.singleton

-- | Level order via paramorphism
-- >>> levelOrder testTree
-- fromList [4,2,5,1,3]
-- >>> levelOrder Leaf
-- fromList []
levelOrder :: forall a. Tree a -> Seq a
levelOrder t =
  nextValue t
    <> flip para t \case
      LeafF -> Seq.empty
      BranchF (l, la) _ (r, ra) -> nextValue l <> nextValue r <> la <> ra
  where
    nextValue :: Tree a -> Seq a
    nextValue = maybeToSeq . root

-- | Longest path via catamorphism
-- >>> longestPath testTree
-- [4,2,3]
longestPath :: forall a. Tree a -> [a]
longestPath = cata \case
  LeafF -> []
  BranchF l a r -> a : maximumBy (compare `on` length) [l, r]

-- | Tree printing via catamorphism
-- >>> putStr $ showTree testTree
-- 4
-- |
-- +--2
-- |  |
-- |  +--1
-- |  |
-- |  `--3
-- |
-- `--5
showTree :: forall a. Show a => Tree a -> String
showTree =
  unlines . cata \case
    LeafF -> []
    BranchF l a r ->
      [show a]
        <> bool (["|  "] <> zipWith (<>) ("+--" : repeat "|  ") l) [] (null l)
        <> bool (["|  "] <> zipWith (<>) ("`--" : repeat "   ") r) [] (null r)

main :: IO ()
main = pure ()