diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,37 @@ +### 0.0.4.8 + +Version bumps + +### 0.0.4.7 + +Supports base-4.17 and GHC 9.4 + +### 0.0.4.6 + +Supports base-4.16 and GHC 9.2 + +### 0.0.4.5 + +Supports base-4.15 and GHC 9.0 + +### 0.0.4.4 + +Supports base-4.14 and GHC 8.8 + +### 0.0.4.2 + +Supports base-4.13 and GHC 8.8 + +### 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,49 +1,46 @@ --- This file has been generated from package.yaml by hpack version 0.20.0. --- --- see: https://github.com/sol/hpack --- --- hash: 0a8c69b63be2cc464d5845e725a023129f39c228c94d1448f9bceb154ca78870 +cabal-version: 3.0 -name: either-list-functions -version: 0.0.0.2 -synopsis: Functions involving lists of Either -description: Functions involving lists of Either -category: Data -homepage: https://github.com/chris-martin/either-list-functions#readme -bug-reports: https://github.com/chris-martin/either-list-functions/issues -author: Chris Martin -maintainer: Chris Martin -license: Apache-2.0 -license-file: license.txt -build-type: Simple -cabal-version: >= 1.10 +name: either-list-functions +version: 0.0.4.8 +category: Data +synopsis: Functions involving lists of Either +description: Functions involving lists of Either. + +homepage: https://github.com/typeclasses/either-list-functions +bug-reports: https://github.com/typeclasses/either-list-functions/issues + +author: Chris Martin +maintainer: Chris Martin, Julie Moronuki + +license: Apache-2.0 +license-file: license.txt + +extra-source-files: *.md + source-repository head - type: git - location: https://github.com/chris-martin/either-list-functions + type: git + location: https://github.com/typeclasses/either-list-functions +common base + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + , base ^>= 4.18 || ^>= 4.19 + library - hs-source-dirs: - src - ghc-options: -Wall - build-depends: - base >=4.9 && <4.11 - exposed-modules: - Data.List.EitherFunctions - other-modules: - Paths_either_list_functions - default-language: Haskell2010 + import: base + hs-source-dirs: src + exposed-modules: Data.List.EitherFunctions + build-depends: + , containers ^>= 0.6.4 test-suite doctest - type: exitcode-stdio-1.0 - main-is: doctest.hs - hs-source-dirs: - test - ghc-options: -Wall -threaded - build-depends: - base >=4.9 && <4.11 - , doctest - , either-list-functions - other-modules: - Paths_either_list_functions - default-language: Haskell2010 + import: base + type: exitcode-stdio-1.0 + main-is: doctest.hs + ghc-options: -threaded + hs-source-dirs: test + build-depends: + , doctest ^>= 0.22 || ^>= 0.23 + , either-list-functions diff --git a/license.txt b/license.txt --- a/license.txt +++ b/license.txt @@ -1,4 +1,4 @@ -Copyright 2017 Chris Martin +Copyright 2017-2021 Mission Valley Software LLC 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,67 +1,285 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BlockArguments, LambdaCase, NoImplicitPrelude #-} +-- | Functions involving lists of 'Either'. + module Data.List.EitherFunctions - ( partlyMap - , groupEither - , spanLeft - , spanRight - ) where + ( -import Data.Either (Either (..)) -import Data.List (map) -import Data.Maybe (Maybe (..), maybe) + {- * 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 = 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 ) + +-- | +-- >>> 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 = 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 "Vertebrates" +-- >>> , p "Cats" +-- >>> , p "Snakes" +-- >>> , section "Invertebrates" +-- >>> , 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 +-- | +-- +- Vertebrates: Cats, Snakes +-- | +-- `- Invertebrates: 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