diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,201 @@ +Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +import Distribution.Extra.Doctest ( defaultMainWithDoctests ) +main :: IO () +main = defaultMainWithDoctests "doctests" diff --git a/doctest/doctests.hs b/doctest/doctests.hs new file mode 100644 --- /dev/null +++ b/doctest/doctests.hs @@ -0,0 +1,14 @@ +module Main where + +import Build_doctests (flags, pkgs, module_sources) +import Data.Foldable (traverse_) +import System.Environment.Compat (unsetEnv) +import Test.DocTest (doctest) + +main :: IO () +main = do + traverse_ putStrLn args + unsetEnv "GHC_ENVIRONMENT" + doctest args + where + args = flags ++ pkgs ++ module_sources diff --git a/kleene-list.cabal b/kleene-list.cabal new file mode 100644 --- /dev/null +++ b/kleene-list.cabal @@ -0,0 +1,53 @@ +cabal-version: >=1.10 + +name: kleene-list +version: 0.1.0.0 +synopsis: A list type based on the Kleene star and plus. +description: This package provides a simple list type which is defined mutually with a non-empty list type. This makes interop between the two simpler. The types take their names from the Kleene star and plus. +license: Apache +license-file: LICENSE +author: Donnacha Oisín Kidney +maintainer: mail@doisinkidney.com +copyright: 2020 Donnacha Oisín Kidney +category: Data +build-type: Custom +extra-source-files: README.md + +source-repository head + type: git + location: https://github.com/oisdk/kleene-list + +custom-setup + setup-depends: + base + , Cabal + , cabal-doctest >=1.0.6 && <1.1 + +library + exposed-modules: + Data.List.Kleene.Internal + Data.List.Kleene.Star + Data.List.Kleene.Plus + hs-source-dirs: + src + ghc-options: -Wall -fwarn-incomplete-record-updates -fwarn-redundant-constraints -Wcompat + build-depends: + base >=4.7 && <5 + , deepseq + default-language: Haskell2010 + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + hs-source-dirs: + doctest + ghc-options: -Wall -fwarn-incomplete-record-updates -fwarn-redundant-constraints -Wcompat -threaded + build-depends: + QuickCheck + , base + , base-compat + , deepseq + , doctest + , kleene-list + , template-haskell + default-language: Haskell2010 diff --git a/src/Data/List/Kleene/Internal.hs b/src/Data/List/Kleene/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Kleene/Internal.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Data.List.Kleene.Internal +-- Description : Common utility functions and definitions for the kleene-list package. +-- Copyright : (c) Donnacha Oisín Kidney, 2020 +-- License : Apache +-- Maintainer : mail@doisinkidney.com +-- Stability : experimental +-- Portability : ghc +-- +-- = WARNING +-- +-- This module is considered __internal__. +-- +-- The Package Versioning Policy __does not apply__. +-- +-- This contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +-- +-- Authors importing this module are expected to track development +-- closely. + +{-# OPTIONS_HADDOCK not-home #-} +module Data.List.Kleene.Internal where + +import Control.DeepSeq (NFData (rnf)) +import Data.Data (Data, Typeable) +import Data.Functor.Classes +import GHC.Generics (Generic) + +import GHC.Exts (IsList) +import qualified GHC.Exts + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Zip +import Data.Foldable + +import Prelude hiding (filter, head, scanl, scanr, tail) + +-- | A list, based on the Kleene star. +-- This type is isomorphic to Haskell's standard @[]@ type, so it can be used +-- in the same way. +data Star a + = Nil + | Cons (Plus a) + deriving (Eq, Ord, Generic, Data, Typeable, Functor, Traversable) + +infixr 5 :- +-- | A non-empty list type, based on the Kleene plus. +-- This type is isomorphic to 'Data.List.NonEmpty.NonEmpty' type, so it +-- can be used in the same way. +data Plus a + = (:-) + { head :: a + , tail :: Star a + } deriving (Eq, Ord, Generic, Data, Typeable, Functor, Traversable) + +instance Foldable Star where + foldr _ b Nil = b + foldr f b (Cons xs) = foldr f b xs + + foldl _ b Nil = b + foldl f b (Cons xs) = foldl f b xs + + foldl' _ !b Nil = b + foldl' f !b (Cons xs) = foldl' f b xs + + foldl1 _ Nil = errorWithoutStackTrace "foldl1: empty list" + foldl1 f (Cons xs) = foldl1 f xs + + foldr1 _ Nil = errorWithoutStackTrace "foldr1: empty list" + foldr1 f (Cons xs) = foldr1 f xs + + foldMap _ Nil = mempty + foldMap f (Cons xs) = foldMap f xs + + minimum Nil = errorWithoutStackTrace "minimum: empty list" + minimum (Cons xs) = minimum xs + + maximum Nil = errorWithoutStackTrace "maximum: empty list" + maximum (Cons xs) = maximum xs + +instance Foldable Plus where + foldr f b ~(x :- xs) = f x (foldr f b xs) + + foldl f b ~(x :- xs) = foldl f (f b x) xs + + foldl' f !b ~(x :- xs) = foldl' f (f b x) xs + + foldl1 f ~(x :- xs) = foldl f x xs + + foldr1 f = go + where + go (x :- xs) = case xs of + Nil -> x + Cons ys -> f x (go ys) + + foldMap f ~(x :- xs) = f x <> foldMap f xs + + null _ = False + + minimum = foldr1 min + maximum = foldr1 max + +instance Eq1 Star where + liftEq _ Nil Nil = True + liftEq eq (Cons xs) (Cons ys) = liftEq eq xs ys + liftEq _ _ _ = False + +instance Eq1 Plus where + liftEq eq ~(x :- xs) (y :- ys) = eq x y && liftEq eq xs ys + +instance Ord1 Star where + liftCompare _ Nil Nil = EQ + liftCompare _ Nil (Cons _) = LT + liftCompare _ (Cons _) Nil = GT + liftCompare c (Cons xs) (Cons ys) = liftCompare c xs ys + +instance Ord1 Plus where + liftCompare c ~(x :- xs) ~(y :- ys) = c x y <> liftCompare c xs ys + +instance Show1 Plus where + liftShowsPrec _ sp _ = sp . foldr (:) [] + +instance Show1 Star where + liftShowsPrec _ sp _ = sp . foldr (:) [] + +-- | A pattern for building up star lists as cons-lists. +-- +-- >>> 1 :* 2 :* 3 :* Nil +-- [1,2,3] +infixr 5 :* +pattern (:*) :: a -> Star a -> Star a +pattern (:*) x xs = Cons (x :- xs) +{-# COMPLETE (:*), Nil #-} + +-- | A pattern for building up plus lists as cons-lists. +-- +-- >>> 1 :+ 2 :+ One 3 +-- [1,2,3] +infixr 5 :+ +pattern (:+) :: a -> Plus a -> Plus a +pattern (:+) x xs = x :- Cons xs + +-- | A pattern for a singleton plus list. +pattern One :: a -> Plus a +pattern One x = x :- Nil +{-# COMPLETE (:+), One #-} + +instance IsList (Star a) where + type Item (Star a) = a + fromList = foldr (:*) Nil + toList = foldr (:) [] + +instance IsList (Plus a) where + type Item (Plus a) = a + fromList [] = errorWithoutStackTrace "Cannot make plus from empty list" + fromList (x:xs) = x :- GHC.Exts.fromList xs + toList = foldr (:) [] + +instance Show a => Show (Star a) where + showsPrec n = showsPrec n . toList + +instance Show a => Show (Plus a) where + showsPrec n = showsPrec n . toList + +instance NFData a => NFData (Star a) where + rnf Nil = () + rnf (Cons xs) = rnf xs + +instance NFData a => NFData (Plus a) where + rnf (x :- xs) = rnf x `seq` rnf xs + +instance Semigroup (Plus a) where + ~(x :- xs) <> ys = x :+ (xs *<>+ ys) + +(*<>+) :: Star a -> Plus a -> Plus a +Nil *<>+ ys = ys +Cons xs *<>+ ys = xs <> ys + +instance Semigroup (Star a) where + Nil <> ys = ys + Cons xs <> ys = Cons (xs +<>* ys) + +(+<>*) :: Plus a -> Star a -> Plus a +~(x :- xs) +<>* ys = x :- (xs <> ys) + +instance Monoid (Star a) where + mempty = Nil + +instance Applicative Star where + pure = Cons . pure + + Nil <*> _ = Nil + f :* fs <*> xs = foldr ((:*) . f) (fs <*> xs) xs + + liftA2 _ Nil _ = Nil + liftA2 f (x :* xs) ys = foldr ((:*) . f x) (liftA2 f xs ys) ys + +-- | +-- >>> (,) <$> (1 :+ 2 :+ One 3) <*> ('a' :+ 'b' :+ One 'c') +-- [(1,'a'),(1,'b'),(1,'c'),(2,'a'),(2,'b'),(2,'c'),(3,'a'),(3,'b'),(3,'c')] +-- +-- >>> liftA2 (,) (1 :+ 2 :+ One 3) ('a' :+ 'b' :+ One 'c') +-- [(1,'a'),(1,'b'),(1,'c'),(2,'a'),(2,'b'),(2,'c'),(3,'a'),(3,'b'),(3,'c')] +instance Applicative Plus where + pure = One + + ~(f' :- fs') <*> xs = f' (head xs) :- foldr ((:*) . f') (go fs') (tail xs) + where + go Nil = Nil + go (f :* fs) = foldr ((:*) . f) (go fs) xs + + liftA2 f ~(x' :- xs') ys = f x' (head ys) :- foldr ((:*) . f x') (go xs') (tail ys) + where + go Nil = Nil + go (x :* xs) = foldr ((:*) . f x) (go xs) ys + +instance Monad Star where + xs >>= f = foldr ((<>) . f) Nil xs + +instance Monad Plus where + ~(x :- xs) >>= f = f x +<>* go xs + where + go Nil = Nil + go (Cons ys) = Cons (ys >>= f) + +instance Alternative Star where + (<|>) = (<>) + empty = Nil + +instance MonadPlus Star + +instance MonadFix Plus where + mfix f = case fix (f . head) of + ~(x :- _) -> x :- mfix (tail . f) + +instance MonadFix Star where + mfix f = case fix (f . head . unStar) of + Nil -> Nil + (x :* _) -> x :* mfix (tail . unStar . f) + where + unStar ~(Cons xs) = xs + +instance MonadZip Plus where + mzip ~(x :- xs) ~(y :- ys) = (x, y) :- mzip xs ys + + mzipWith f ~(x :- xs) ~(y :- ys) = f x y :- mzipWith f xs ys + + munzip ~(~(y,z) :- xs) = (y :- ys, z :- zs) + where + ~(ys,zs) = munzip xs + +instance MonadZip Star where + mzip Nil _ = Nil + mzip _ Nil = Nil + mzip (Cons xs) (Cons ys) = Cons (mzip xs ys) + + mzipWith _ Nil _ = Nil + mzipWith _ _ Nil = Nil + mzipWith f (Cons xs) (Cons ys) = Cons (mzipWith f xs ys) + + munzip Nil = (Nil, Nil) + munzip (Cons xs) = (Cons ys, Cons zs) + where + ~(ys,zs) = munzip xs + +merge :: (a -> a -> Ordering) -> Star a -> Star a -> Star a +merge _ Nil ys = ys +merge cmp (Cons xs) ys = Cons (mergel cmp xs ys) + +mergel :: (a -> a -> Ordering) -> Plus a -> Star a -> Plus a +mergel _ xs Nil = xs +mergel cmp xs (Cons ys) = mergelr cmp xs ys + +merger :: (a -> a -> Ordering) -> Star a -> Plus a -> Plus a +merger _ Nil ys = ys +merger cmp (Cons xs) ys = mergelr cmp xs ys + +mergelr :: (a -> a -> Ordering) -> Plus a -> Plus a -> Plus a +mergelr cmp xss@ ~(x :- xs) yss@ ~(y :- ys) = case cmp x y of + LT -> x :+ merger cmp xs yss + EQ -> x :+ y :- merge cmp xs ys + GT -> y :+ mergel cmp xss ys + +treeFoldMap :: (a -> b) -> (b -> b -> b) -> Plus a -> b +treeFoldMap c f = go + where + go (One x) = c x + go (x :+ y :- xs) = go' (f (c x) (c y) :- pairMap xs) + + pairMap (x1 :* x2 :* xs) = f (c x1) (c x2) :* pairMap xs + pairMap (x1 :* Nil) = c x1 :* Nil + pairMap Nil = Nil + + go' (One x) = x + go' (x :+ y :- xs) = go' (f x y :- pairMap' xs) + + pairMap' (x1 :* x2 :* xs) = f x1 x2 :* pairMap' xs + pairMap' xs = xs + +-- | +-- >>> prescanlPlus (+) 0 [1,2,3] +-- [1,3,6] +prescanlPlus :: (b -> a -> b) -> b -> Plus a -> Plus b +prescanlPlus f b (x :- xs) = scanl f (f b x) xs + +-- | +-- >>> prescanlStar (+) 0 [1,2,3] +-- [1,3,6] +prescanlStar :: (b -> a -> b) -> b -> Star a -> Star b +prescanlStar _ _ Nil = Nil +prescanlStar f b (Cons xs) = Cons (prescanlPlus f b xs) + +-- | Functions the same as 'Data.List.scanl' in "Data.List". +-- +-- >>> scanl (+) 0 [1,2,3] +-- [0,1,3,6] +scanl :: (b -> a -> b) -> b -> Star a -> Plus b +scanl f b xs = b :- prescanlStar f b xs + +-- | Functions the same as 'Data.List.scanr' in "Data.List". +-- +-- >>> scanr (+) 0 ([1,2,3] :: Star Int) +-- [6,5,3,0] +scanr :: Foldable f => (a -> b -> b) -> b -> f a -> Plus b +scanr f b = foldr (\x xs -> f x (head xs) :+ xs) (One b) + +-- | Functions the same as 'Data.List.filter' in "Data.List". +-- +-- >>> filter even ([1..5] :: Star Int) +-- [2,4] +filter :: Foldable f => (a -> Bool) -> f a -> Star a +filter p = foldr f Nil + where + f x xs + | p x = x :* xs + | otherwise = xs + +takeStar :: Int -> Star a -> Star a +takeStar _ Nil = Nil +takeStar i (Cons xs) = takePlus i xs + +takePlus :: Int -> Plus a -> Star a +takePlus 0 _ = Nil +takePlus i ~(x :- xs) = x :* takeStar (i-1) xs + +indexPlus :: Plus a -> Int -> a +indexPlus xs 0 = head xs +indexPlus xs i = indexStar (tail xs) (i-1) + +indexStar :: Star a -> Int -> a +indexStar Nil _ = errorWithoutStackTrace "index: empty list!" +indexStar (Cons xs) i = indexPlus xs i + + +-- $setup +-- >>> :set -XOverloadedLists diff --git a/src/Data/List/Kleene/Plus.hs b/src/Data/List/Kleene/Plus.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Kleene/Plus.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Data.List.Kleene.Star +-- Description : A list type isomorphic to 'Data.List.NonEmpty.NonEmpty' based on the Kleene plus. +-- Copyright : (c) Donnacha Oisín Kidney, 2020 +-- License : Apache +-- Maintainer : mail@doisinkidney.com +-- Stability : experimental +-- Portability : ghc +-- +-- This module provides a simple list type isomorphic to 'Data.List.NonEmpty.NonEmpty', +-- but which is defined in terms of a possibly empty list +-- type. This can make moving between one type and another +-- easier. + +module Data.List.Kleene.Plus + ( -- * The list type + Plus(..) + ,pattern (:+) + ,pattern One + ,Star(..) + -- * Utility functions + ,last + ,filter + ,reverse + ,take + ,(!!) + -- * Building lists + ,unfoldr + ,iterate + ,cycle + -- * scans + ,scanr + ,scanl + ,prescanr + ,prescanl + -- * Sorting + ,sortBy + ,sortOn + ,sort + ) + where + +import Data.List.Kleene.Internal + +import Data.Ord + +import Prelude hiding (cycle, filter, head, iterate, + last, reverse, scanl, scanr, take, + (!!)) + +-- | Sort given a comparison function. Stable. +-- \(\mathcal{O}(n \log n)\). +-- +-- >>> sortBy (\x y -> compare (fst x) (fst y)) [(4,1),(3,2),(1,3),(3,4)] +-- [(1,3),(3,2),(3,4),(4,1)] +sortBy :: (a -> a -> Ordering) -> Plus a -> Plus a +sortBy cmp = treeFoldMap One (mergelr cmp) + +-- | Sort given a selector function. Stable. +-- \(\mathcal{O}(n \log n)\). +-- +-- >>> sortOn fst [(4,1),(3,2),(1,3),(3,4)] +-- [(1,3),(3,2),(3,4),(4,1)] +sortOn :: Ord b => (a -> b) -> Plus a -> Plus a +sortOn c = fmap fst . treeFoldMap (\x -> One (x, c x)) (mergelr (comparing snd)) + +-- | Stable sort. +-- \(\mathcal{O}(n \log n)\). +-- +-- >>> sort [4,3,1,3] +-- [1,3,3,4] +sort :: Ord a => Plus a -> Plus a +sort = sortBy compare + +-- | Return the last element of a finite list. +-- +-- >>> last [1..10] +-- 10 +last :: Plus a -> a +last = foldl1 (\_ x -> x) + +-- | Unfold a list from a seed. +unfoldr :: (b -> (a, Maybe b)) -> b -> Plus a +unfoldr f b = x :- maybe Nil (Cons . unfoldr f) xs + where + (x,xs) = f b + +-- | Cycle a list infinitely +-- +-- >>> take 10 (cycle [1..3]) +-- [1,2,3,1,2,3,1,2,3,1] +cycle :: Plus a -> Plus a +cycle xs = ys + where + ys = xs <> ys + +-- | Repeatedly apply a function, listing its output. +-- +-- >>> take 5 (iterate (+1) 1) +-- [1,2,3,4,5] +iterate :: (a -> a) -> a -> Plus a +iterate f x = x :+ iterate f (f x) + +-- | Like 'scanr', but without including the initial element in the output. +-- +-- >>> prescanr (+) 0 [1,2,3] +-- [6,5,3] +prescanr :: (a -> b -> b) -> b -> Plus a -> Plus b +prescanr f b (One x) = One (f x b) +prescanr f b (x :+ xs) = f x (head ys) :+ ys + where + ys = prescanr f b xs + +-- | Like 'scanl', but without including the initial element in the output. +-- +-- >>> prescanl (+) 0 [1,2,3] +-- [1,3,6] +prescanl :: (b -> a -> b) -> b -> Plus a -> Plus b +prescanl = prescanlPlus + +-- | Reverse a list. +-- +-- >>> reverse [1..5] +-- [5,4,3,2,1] +reverse :: Plus a -> Plus a +reverse (x :- xs) = foldl (flip (:+)) (One x) xs + +-- | @'take' n xs@ takes the first @n@ elements from @xs@. +-- +-- >>> take 5 [1..] +-- [1,2,3,4,5] +-- +-- >>> take 5 [1..3] +-- [1,2,3] +take :: Int -> Plus a -> Star a +take = takePlus + +-- | Index into a list. +-- +-- >>> [0..] !! 3 +-- 3 +-- +-- >>> [0..5] !! 6 +-- *** Exception: index: empty list! +(!!) :: Plus a -> Int -> a +(!!) = indexPlus + +-- $setup +-- >>> :set -XOverloadedLists diff --git a/src/Data/List/Kleene/Star.hs b/src/Data/List/Kleene/Star.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Kleene/Star.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Data.List.Kleene.Star +-- Description : A list type isomorphic to [] based on the Kleene star. +-- Copyright : (c) Donnacha Oisín Kidney, 2020 +-- License : Apache +-- Maintainer : mail@doisinkidney.com +-- Stability : experimental +-- Portability : ghc +-- +-- This module provides a simple list type isomorphic to Haskell's +-- standard @[]@, but which is defined in terms of a non-empty list +-- type. This can make moving between one type and another +-- easier. + +module Data.List.Kleene.Star + ( -- * The list type + Star(..) + ,pattern (:*) + ,Plus(..) + -- * Utility functions + ,filter + ,reverse + ,uncons + ,take + ,(!!) + -- * Building lists + ,unfoldr + -- * scans + ,scanr + ,scanl + ,prescanl + ,prescanr + -- * Sorting + ,sortBy + ,sortOn + ,sort + ) + where + +import Data.List.Kleene.Internal +import Data.Ord +import Prelude hiding (filter, head, reverse, scanl, + scanr, take, (!!)) + +-- | Sort given a comparison function. Stable. +-- \(\mathcal{O}(n \log n)\). +-- +-- >>> sortBy (\x y -> compare (fst x) (fst y)) [(4,1),(3,2),(1,3),(3,4)] +-- [(1,3),(3,2),(3,4),(4,1)] +sortBy :: (a -> a -> Ordering) -> Star a -> Star a +sortBy _ Nil = Nil +sortBy cmp (Cons xs) = Cons (treeFoldMap One (mergelr cmp) xs) + +-- | Sort given a selector function. Stable. +-- \(\mathcal{O}(n \log n)\). +-- +-- >>> sortOn fst [(4,1),(3,2),(1,3),(3,4)] +-- [(1,3),(3,2),(3,4),(4,1)] +sortOn :: Ord b => (a -> b) -> Star a -> Star a +sortOn _ Nil = Nil +sortOn c (Cons xs) = Cons (fmap fst (treeFoldMap (\x -> One (x, c x)) (mergelr (comparing snd)) xs)) + +-- | Stable sort. +-- \(\mathcal{O}(n \log n)\). +-- +-- >>> sort [4,3,1,3] +-- [1,3,3,4] +sort :: Ord a => Star a -> Star a +sort = sortBy compare + +-- | Unfold a list from a seed. +unfoldr :: (b -> Maybe (a, b)) -> b -> Star a +unfoldr f b = maybe Nil (\(x, xs) -> x :* unfoldr f xs) (f b) + +-- | Like 'scanl', but without including the initial element in the output. +-- +-- >>> prescanl (+) 0 [1,2,3] +-- [1,3,6] +prescanl :: (b -> a -> b) -> b -> Star a -> Star b +prescanl = prescanlStar + +-- | Like 'scanr', but without including the initial element in the output. +-- +-- >>> prescanr (+) 0 [1,2,3] +-- [6,5,3] +prescanr :: (a -> b -> b) -> b -> Star a -> Star b +prescanr _ _ Nil = Nil +prescanr f b (Cons xs) = Cons (go xs) + where + go (One x) = One (f x b) + go (y :+ ys) = f y (head zs) :+ zs + where + zs = go ys + +-- | Reverse a list. +-- +-- >>> reverse [1..5] +-- [5,4,3,2,1] +reverse :: Star a -> Star a +reverse = foldl (flip (:*)) Nil + +-- | Convert to a 'Plus' list. +uncons :: Star a -> Maybe (Plus a) +uncons Nil = Nothing +uncons (Cons xs) = Just xs + +-- | @'take' n xs@ takes the first @n@ elements from @xs@. +-- +-- >>> take 5 [1..] +-- [1,2,3,4,5] +-- +-- >>> take 5 [1..3] +-- [1,2,3] +take :: Int -> Star a -> Star a +take = takeStar + +-- | Index into a list. +-- +-- >>> [0..] !! 3 +-- 3 +-- +-- >>> [0..5] !! 6 +-- *** Exception: index: empty list! +(!!) :: Star a -> Int -> a +(!!) = indexStar + +-- $setup +-- >>> :set -XOverloadedLists