diff --git a/changelog.txt b/changelog.txt --- a/changelog.txt +++ b/changelog.txt @@ -1,3 +1,15 @@ +0.0.4.0 + - Added: + - spanLeft' + - spanRight' + - leadLeft + - leadLeft' + - leadRight + - leadRight' + - branchLeft + - branchRight + - BranchComparison + 0.0.2.0 - Supports base-4.12 - Added 'partition' function diff --git a/either-list-functions.cabal b/either-list-functions.cabal --- a/either-list-functions.cabal +++ b/either-list-functions.cabal @@ -1,5 +1,5 @@ name: either-list-functions -version: 0.0.2.0 +version: 0.0.4.0 category: Data synopsis: Functions involving lists of Either @@ -28,12 +28,14 @@ default-language: Haskell2010 hs-source-dirs: src ghc-options: -Wall + exposed-modules: Data.List.EitherFunctions + build-depends: base, containers - build-depends: - base >=4.9 && <4.13 + -- require Data.Functor.Contravariant + build-depends: base >=4.12 - exposed-modules: - Data.List.EitherFunctions + -- upper bounds to exclude untested versions + build-depends: base <4.13, containers <0.7 test-suite doctest default-language: Haskell2010 @@ -41,8 +43,9 @@ main-is: doctest.hs ghc-options: -Wall -threaded hs-source-dirs: test + build-depends: base, doctest, either-list-functions - build-depends: - base >=4.9 && <4.13 - , doctest - , either-list-functions + build-depends: base >=4.12 + + -- upper bounds to exclude untested versions + build-depends: base <4.13 diff --git a/license.txt b/license.txt --- a/license.txt +++ b/license.txt @@ -1,4 +1,4 @@ -Copyright 2017 Chris Martin +Copyright 2017-2020 Chris Martin Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/src/Data/List/EitherFunctions.hs b/src/Data/List/EitherFunctions.hs --- a/src/Data/List/EitherFunctions.hs +++ b/src/Data/List/EitherFunctions.hs @@ -1,80 +1,285 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BlockArguments, LambdaCase, NoImplicitPrelude #-} -module Data.List.EitherFunctions - ( partlyMap - , groupEither - , spanLeft - , spanRight - , partition - ) where +-- | Functions involving lists of 'Either'. -import Data.Either (Either (..)) -import Data.Maybe (Maybe (..), maybe) +module Data.List.EitherFunctions + ( -import qualified Data.List as List + {- * Map -} partlyMap, + {- * Group -} groupEither, + {- * Partition -} partition, + {- * Span -} spanLeft, spanLeft', spanRight, spanRight', + {- * Lead -} leadLeft, leadLeft', leadRight, leadRight', + {- * Branch -} branchLeft, branchRight, BranchComparison -{- | + ) where ->>> import Prelude (even, show) +import Data.Bool ( Bool (..) ) +import Data.Either ( Either (..) ) +import Data.Function ( fix ) +import Data.Functor.Contravariant ( Comparison (..), contramap ) +import Data.List ( foldr, map, span ) +import Data.Tree ( Tree (..), Forest ) +import Data.Maybe ( Maybe (..), maybe ) +import Data.Ord ( Ordering (..) ) ->>> partlyMap (\x -> if even x then Just (show x) else Nothing) [1..5] -[Left 1,Right "2",Left 3,Right "4",Left 5] +-- | +-- >>> import Prelude (even, show) +-- +-- >>> partlyMap (\x -> if even x then Just (show x) else Nothing) [1..5] +-- [Left 1,Right "2",Left 3,Right "4",Left 5] --} partlyMap :: (a -> Maybe b) -> [a] -> [Either a b] -partlyMap f = List.map (\x -> maybe (Left x) Right (f x)) -{- | +partlyMap f = map \x -> maybe (Left x) Right (f x) ->>> groupEither [Left 1, Left 2, Right 'a', Left 3, Right 'b', Right 'c'] -[Left [1,2],Right "a",Left [3],Right "bc"] +-- | +-- >>> groupEither [Left 1, Left 2, Right 'a', Left 3, Right 'b', Right 'c'] +-- [Left [1,2],Right "a",Left [3],Right "bc"] --} groupEither :: [Either a b] -> [Either [a] [b]] -groupEither [] = [] -groupEither ((Left x) : xs) = let (ys, zs) = spanLeft xs - in Left (x : ys) : groupEither zs -groupEither ((Right x) : xs) = let (ys, zs) = spanRight xs - in Right (x : ys) : groupEither zs -{- | +groupEither = fix \r -> \case + [] -> [] + Left x : xs -> Left (x : ys) : r zs where (ys, zs) = spanLeft xs + Right x : xs -> Right (x : ys) : r zs where (ys, zs) = spanRight xs ->>> spanLeft [Left 1, Left 2, Right 'a', Left 3, Right 'b', Right 'c'] -([1,2],[Right 'a',Left 3,Right 'b',Right 'c']) +-- | +-- >>> leadLeft [Right 'a', Right 'b', Left 1, Right 'c', Right 'd', Left 2, Right 'e', Right 'f'] +-- ("ab",[(1,"cd"),(2,"ef")]) +-- +-- >>> leadLeft [Left 1, Left 2, Right 'a', Left 3, Right 'b', Right 'c'] +-- ("",[(1,""),(2,"a"),(3,"bc")]) ->>> spanLeft [Right 'a', Left 3, Right 'b', Right 'c'] -([],[Right 'a',Left 3,Right 'b',Right 'c']) +leadLeft :: [Either a b] -> ([b], [(a, [b])]) --} +leadLeft = f + where + f xs = (unledItems, ledGroups) + where + (unledItems, ysMaybe) = spanRight' xs + ledGroups = case ysMaybe of + Nothing -> [] + Just (leader, ys) -> r leader ys + + r leader xs = firstGroup : moreGroups + where + firstGroup = (leader, followers) + (followers, ysMaybe) = spanRight' xs + moreGroups = case ysMaybe of + Nothing -> [] + Just (leader', ys) -> r leader' ys + +-- | +-- >>> leadLeft' 0 [Right 'a', Right 'b', Left 1, Right 'c', Right 'd', Left 2, Right 'e', Right 'f'] +-- [(0,"ab"),(1,"cd"),(2,"ef")] +-- +-- >>> leadLeft' 0 [Left 1, Left 2, Right 'a', Left 3, Right 'b', Right 'c'] +-- [(1,""),(2,"a"),(3,"bc")] + +leadLeft' :: + a -- ^ Leader to use for the first group in case the list does not begin with a 'Left'. + -> [Either a b] -> [(a, [b])] + +leadLeft' leader xs = addMissingLeader leader (leadLeft xs) + +-- | +-- >>> leadRight [Left 1, Left 2, Right 'a', Left 3, Left 4, Right 'b', Left 5, Left 6] +-- ([1,2],[('a',[3,4]),('b',[5,6])]) +-- +-- >>> leadRight [Right 'a', Left 3, Left 4, Right 'b', Right 'c', Left 5, Left 6] +-- ([],[('a',[3,4]),('b',[]),('c',[5,6])]) + +leadRight :: [Either a b] -> ([a], [(b, [a])]) + +leadRight = f + where + f xs = (unledItems, ledGroups) + where + (unledItems, ysMaybe) = spanLeft' xs + ledGroups = case ysMaybe of + Nothing -> [] + Just (leader, ys) -> r leader ys + + r leader xs = firstGroup : moreGroups + where + firstGroup = (leader, followers) + (followers, ysMaybe) = spanLeft' xs + moreGroups = case ysMaybe of + Nothing -> [] + Just (leader', ys) -> r leader' ys + +-- | +-- >>> leadRight' 'z' [Left 1, Left 2, Right 'a', Left 3, Left 4, Right 'b', Left 5, Left 6] +-- [('z',[1,2]),('a',[3,4]),('b',[5,6])] +-- +-- >>> leadRight' 'z' [Right 'a', Left 3, Left 4, Right 'b', Right 'c', Left 5, Left 6] +-- [('a',[3,4]),('b',[]),('c',[5,6])] + +leadRight' :: + b -- ^ Leader to use for the first group in case the list does not begin with a 'Right'. + -> [Either a b] -> [(b, [a])] + +leadRight' leader xs = addMissingLeader leader (leadRight xs) + +addMissingLeader :: a -> ([b], [(a, [b])]) -> [(a, [b])] + +addMissingLeader _ ( [] , groups ) = groups +addMissingLeader leader ( unledIntro , groups ) = (leader, unledIntro) : groups + +-- | +-- >>> spanLeft [Left 1, Left 2, Right 'a', Left 3, Right 'b', Right 'c'] +-- ([1,2],[Right 'a',Left 3,Right 'b',Right 'c']) +-- +-- >>> spanLeft [Right 'a', Left 3, Right 'b', Right 'c'] +-- ([],[Right 'a',Left 3,Right 'b',Right 'c']) + spanLeft :: [Either a b] -> ([a], [Either a b]) -spanLeft [] = ([], []) -spanLeft ((Left x) : xs) = let (ys, zs) = spanLeft xs - in (x : ys, zs) -spanLeft xs = ([], xs) -{- | +spanLeft = fix \r -> \case + [] -> ( [] , [] ) + Left x : xs -> ( x : ys , zs ) where (ys, zs) = r xs + xs -> ( [] , xs ) ->>> spanRight [Left 1, Left 2, Right 'a', Left 3, Right 'b', Right 'c'] -("",[Left 1,Left 2,Right 'a',Left 3,Right 'b',Right 'c']) +-- | Similar to 'spanLeft', but preserves a little more information in the return type: if the remainder of the list is non-empty, then it necessarily begins with a 'Right', and so we can go ahead and unwrap that and return it as a value of type `b`. +-- +-- >>> spanLeft' [Left 1, Left 2, Right 'a', Left 3, Right 'b', Right 'c'] +-- ([1,2],Just ('a',[Left 3,Right 'b',Right 'c'])) +-- +-- >>> spanLeft' [Right 'a', Left 3, Right 'b', Right 'c'] +-- ([],Just ('a',[Left 3,Right 'b',Right 'c'])) +-- +-- >>> spanLeft' [Left 1, Left 2, Left 3] +-- ([1,2,3],Nothing) ->>> spanRight [Right 'a', Left 3, Right 'b', Right 'c'] -("a",[Left 3,Right 'b',Right 'c']) +spanLeft' :: [Either a b] -> ([a], Maybe (b, [Either a b])) --} +spanLeft' = fix \r -> \case + [] -> ( [] , Nothing ) + Left x : xs -> ( x : ys , zs ) where (ys, zs) = r xs + Right x : xs -> ( [] , Just (x, xs) ) + +-- | Similar to 'spanRight', but preserves a little more information in the return type: if the remainder of the list is non-empty, then it necessarily begins with a 'Left', and so we can go ahead and unwrap that and return it as a value of type `a`. +-- +-- >>> spanRight [Left 1, Left 2, Right 'a', Left 3, Right 'b', Right 'c'] +-- ("",[Left 1,Left 2,Right 'a',Left 3,Right 'b',Right 'c']) +-- +-- >>> spanRight [Right 'a', Left 3, Right 'b', Right 'c'] +-- ("a",[Left 3,Right 'b',Right 'c']) + spanRight :: [Either a b] -> ([b], [Either a b]) -spanRight [] = ([], []) -spanRight ((Right x) : xs) = let (ys, zs) = spanRight xs - in (x : ys, zs) -spanRight xs = ([], xs) -{- | +spanRight = fix \r -> \case + [] -> ( [] , [] ) + Right x : xs -> ( x : ys , zs ) where (ys, zs) = r xs + xs -> ( [] , xs ) ->>> partition [Left 1, Left 2, Right 'a', Left 3, Right 'b', Right 'c'] -([1,2,3],"abc") +-- | +-- >>> spanRight' [Left 1, Left 2, Right 'a', Left 3, Right 'b', Right 'c'] +-- ("",Just (1,[Left 2,Right 'a',Left 3,Right 'b',Right 'c'])) +-- +-- >>> spanRight' [Right 'a', Left 3, Right 'b', Right 'c'] +-- ("a",Just (3,[Right 'b',Right 'c'])) +-- +-- >>> spanRight' [Right 'a', Right 'b', Right 'c'] +-- ("abc",Nothing) --} +spanRight' :: [Either a b] -> ([b], Maybe (a, [Either a b])) + +spanRight' = fix \r -> \case + [] -> ( [] , Nothing ) + Right x : xs -> ( x : ys , zs ) where (ys, zs) = r xs + Left x : xs -> ( [] , Just (x, xs) ) + +-- | +-- >>> partition [Left 1, Left 2, Right 'a', Left 3, Right 'b', Right 'c'] +-- ([1,2,3],"abc") + partition :: [Either a b] -> ([a], [b]) -partition [] = ([], []) -partition (x : xs) = let (as, bs) = partition xs - in case x of Left a -> (a : as, bs) - Right b -> (as, b : bs) + +partition = fix \r -> \case + [] -> ( [] , [] ) + Left a : xs -> ( a : as , bs ) where (as, bs) = r xs + Right b : xs -> ( as , b : bs ) where (as, bs) = r xs + +-- | The relative significance of branches (greater values are closer to the root). +type BranchComparison a = Comparison a + +-- | +-- >>> import Prelude +-- +-- >>> heading level title = Left (level, title) +-- >>> chapter = heading 1 +-- >>> section = heading 2 +-- >>> p text = Right text +-- +-- >>> :{ +-- >>> list = +-- >>> [ p "Copyright" +-- >>> , p "Preface" +-- >>> , chapter "Animals" +-- >>> , p "The kingdom animalia" +-- >>> , section "Vertibrates" +-- >>> , p "Cats" +-- >>> , p "Snakes" +-- >>> , section "Invertibrates" +-- >>> , p "Worms" +-- >>> , p "Jellyfishes" +-- >>> , chapter "Fungus" +-- >>> , p "Yeast" +-- >>> , p "Truffles" +-- >>> , p "Morels" +-- >>> ] +-- >>> :} +-- +-- >>> import Data.Functor.Contravariant +-- >>> flipComparison (Comparison f) = Comparison (flip f) +-- >>> headingComparison = contramap fst (flipComparison defaultComparison) +-- +-- >>> (frontMatter, mainMatter) = branchLeft headingComparison list +-- +-- >>> frontMatter +-- ["Copyright","Preface"] +-- +-- >>> import Data.List +-- >>> showContent ((_, x), ys) = x ++ ": " ++ intercalate ", " ys +-- +-- >>> import Data.Tree +-- >>> putStrLn $ drawForest $ map (fmap showContent) mainMatter +-- Animals: The kingdom animalia +-- | +-- +- Vertibrates: Cats, Snakes +-- | +-- `- Invertibrates: Worms, Jellyfishes +-- +-- Fungus: Yeast, Truffles, Morels +-- +-- + +branchLeft :: BranchComparison a -> [Either a b] -> ([b], Forest (a, [b])) + +branchLeft c xs = (rejects, forest) + where + (rejects, nodes) = leadLeft xs + forest = makeForest c' nodes + c' = contramap (\(x, _) -> x) c + +-- | Same as 'branchLeft', but with the types flipped; here, 'Right' is the case that indicates a branch. + +branchRight :: BranchComparison b -> [Either a b] -> ([a], Forest (b, [a])) + +branchRight c xs = (rejects, forest) + where + (rejects, nodes) = leadRight xs + forest = makeForest c' nodes + c' = contramap (\(x, _) -> x) c + +makeForest :: BranchComparison a -> [a] -> Forest a + +makeForest c = foldr f [] + where + f x xs = Node x chomped : remainder + where + (chomped, remainder) = span (\(Node y _) -> x > y) xs + + x > y = case getComparison c x y of GT -> True; _ -> False