diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +## 0.1.0.0 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 Michael Snoyman, http://www.fpcomplete.com/ + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +## minlen + +Express the minimum length of a container in its type. + +Originally part of mono-traversable, split out into its own package. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/minlen.cabal b/minlen.cabal new file mode 100644 --- /dev/null +++ b/minlen.cabal @@ -0,0 +1,26 @@ +name: minlen +version: 0.1.0.0 +synopsis: Express the minimum length of a container in its type +description: Please see README.md +homepage: https://github.com/snoyberg/mono-traversable#readme +license: MIT +license-file: LICENSE +author: Michael Snoyman +maintainer: michael@snoyman.com +category: Data +build-type: Simple +extra-source-files: README.md ChangeLog.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Data.MinLen + build-depends: base >= 4.7 && < 5 + , mono-traversable + , semigroups + , transformers + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/snoyberg/mono-traversable diff --git a/src/Data/MinLen.hs b/src/Data/MinLen.hs new file mode 100644 --- /dev/null +++ b/src/Data/MinLen.hs @@ -0,0 +1,518 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Data.MinLen + ( -- * Type level naturals + -- ** Peano numbers + -- $peanoNumbers + Zero (..) + , Succ (..) + , TypeNat (..) + , AddNat + , MaxNat + -- * Minimum length newtype wrapper + , MinLen + , unMinLen + , toMinLenZero + , toMinLen + , unsafeToMinLen + , mlcons + , mlappend + , mlunion + , head + , last + , tailML + , initML + , GrowingAppend + , ofoldMap1 + , ofold1 + , ofoldr1 + , ofoldl1' + , maximum + , minimum + , maximumBy + , minimumBy + ) where + +import Prelude (Num (..), Maybe (..), Int, Ordering (..), Eq, Ord (..), Read, Show, Functor (..), ($), flip, const) +import Data.Data (Data) +import Data.Typeable (Typeable) +import Control.Category +import Data.MonoTraversable +import Data.Sequences +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup (..)) +#if !MIN_VERSION_base(4,8,0) +import Control.Monad (liftM) +#endif +import Control.Monad.Trans.State.Strict (evalState, state) + +-- $peanoNumbers +-- are a simple way to +-- represent natural numbers (0, 1, 2...) using only a 'Zero' value and a +-- successor function ('Succ'). Each application of 'Succ' increases the number +-- by 1, so @Succ Zero@ is 1, @Succ (Succ Zero)@ is 2, etc. + +-- | 'Zero' is the base value for the Peano numbers. +data Zero = Zero + +-- | 'Succ' represents the next number in the sequence of natural numbers. +-- +-- It takes a @nat@ (a natural number) as an argument. +-- +-- 'Zero' is a @nat@, allowing @'Succ' 'Zero'@ to represent 1. +-- +-- 'Succ' is also a @nat@, so it can be applied to itself, allowing +-- @'Succ' ('Succ' 'Zero')@ to represent 2, +-- @'Succ' ('Succ' ('Succ' 'Zero'))@ to represent 3, and so on. +data Succ nat = Succ nat + +-- | Type-level natural number utility typeclass +class TypeNat nat where + -- | Turn a type-level natural number into a number + -- + -- @ + -- > 'toValueNat' 'Zero' + -- 0 + -- > 'toValueNat' ('Succ' ('Succ' ('Succ' 'Zero'))) + -- 3 + -- @ + toValueNat :: Num i => nat -> i + + -- | Get a data representation of a natural number type + -- + -- @ + -- > 'typeNat' :: 'Succ' ('Succ' 'Zero') + -- Succ (Succ Zero) -- Errors because Succ and Zero have no Show typeclass, + -- -- But this is what it would look like if it did. + -- @ + typeNat :: nat + +instance TypeNat Zero where + toValueNat Zero = 0 + typeNat = Zero +instance TypeNat nat => TypeNat (Succ nat) where + toValueNat (Succ nat) = 1 + toValueNat nat + typeNat = Succ typeNat + +-- | Adds two type-level naturals. +-- +-- See the 'mlappend' type signature for an example. +-- +-- @ +-- > :t 'typeNat' :: 'AddNat' ('Succ' ('Succ' 'Zero')) ('Succ' 'Zero') +-- +-- 'typeNat' :: 'AddNat' ('Succ' ('Succ' 'Zero')) ('Succ' 'Zero') +-- :: 'Succ' ('Succ' ('Succ' 'Zero')) +-- @ +type family AddNat x y +type instance AddNat Zero y = y +type instance AddNat (Succ x) y = AddNat x (Succ y) + +-- | Calculates the maximum of two type-level naturals. +-- +-- See the 'mlunion' type signature for an example. +-- +-- @ +-- > :t 'typeNat' :: 'MaxNat' ('Succ' ('Succ' 'Zero')) ('Succ' 'Zero') +-- +-- 'typeNat' :: 'MaxNat' ('Succ' ('Succ' 'Zero')) ('Succ' 'Zero') +-- :: 'Succ' ('Succ' 'Zero') +-- @ +type family MaxNat x y +type instance MaxNat Zero y = y +type instance MaxNat x Zero = x +type instance MaxNat (Succ x) (Succ y) = Succ (MaxNat x y) + +-- | A wrapper around a container which encodes its minimum length in the type system. +-- This allows functions like 'head' and 'maximum' to be made safe without using 'Maybe'. +-- +-- The length, @nat@, is encoded as a , +-- which starts with the 'Zero' constructor and is made one larger with each application +-- of 'Succ' ('Zero' for 0, @'Succ' 'Zero'@ for 1, @'Succ' ('Succ' 'Zero')@ for 2, etc.). +-- Functions which require at least one element, then, are typed with @Succ nat@, +-- where @nat@ is either 'Zero' or any number of applications of 'Succ': +-- +-- @ +-- 'head' :: 'MonoTraversable' mono => 'MinLen' ('Succ' nat) mono -> 'Element' mono +-- @ +-- +-- The length is also a , +-- i.e. it is only used on the left hand side of the type and doesn't exist at runtime. +-- Notice how @'Succ' 'Zero'@ isn't included in the printed output: +-- +-- @ +-- > 'toMinLen' [1,2,3] :: 'Maybe' ('MinLen' ('Succ' 'Zero') ['Int']) +-- 'Just' ('MinLen' {unMinLen = [1,2,3]}) +-- @ +-- +-- You can still use GHCI's @:i@ command to see the phantom type information: +-- +-- @ +-- > let xs = 'mlcons' 1 $ 'toMinLenZero' [] +-- > :i xs +-- xs :: 'Num' t => 'MinLen' ('Succ' 'Zero') [t] +-- @ +newtype MinLen nat mono = + MinLen { + unMinLen :: mono -- ^ Get the monomorphic container out of a 'MinLen' wrapper. + } deriving (Eq, Ord, Read, Show, Data, Typeable) + +type instance Element (MinLen nat mono) = Element mono +deriving instance MonoFunctor mono => MonoFunctor (MinLen nat mono) +deriving instance MonoFoldable mono => MonoFoldable (MinLen nat mono) +instance MonoTraversable mono => MonoTraversable (MinLen nat mono) where + otraverse f (MinLen x) = fmap MinLen (otraverse f x) + {-# INLINE otraverse #-} +#if !MIN_VERSION_base(4,8,0) + omapM f (MinLen x) = liftM MinLen (omapM f x) + {-# INLINE omapM #-} +#endif +deriving instance GrowingAppend mono => GrowingAppend (MinLen nat mono) + +-- | This function is unsafe, and must not be exposed from this module. +unsafeMap :: (mono -> mono) -> MinLen nat mono -> MinLen nat mono +unsafeMap f (MinLen x) = MinLen (f x) + +instance (Semigroup mono, GrowingAppend mono) => Semigroup (MinLen nat mono) where + MinLen x <> MinLen y = MinLen (x <> y) + +instance SemiSequence seq => SemiSequence (MinLen nat seq) where + type Index (MinLen nat seq) = Index seq + + intersperse e = unsafeMap $ intersperse e + reverse = unsafeMap reverse + find f = find f . unMinLen + cons x = unsafeMap $ cons x + snoc xs x = unsafeMap (flip snoc x) xs + sortBy f = unsafeMap $ sortBy f + +instance MonoPointed mono => MonoPointed (MinLen Zero mono) where + opoint = MinLen . opoint + {-# INLINE opoint #-} +instance MonoPointed mono => MonoPointed (MinLen (Succ Zero) mono) where + opoint = MinLen . opoint + {-# INLINE opoint #-} + +-- | Get the 'typeNat' of a 'MinLen' container. +natProxy :: TypeNat nat => MinLen nat mono -> nat +natProxy _ = typeNat + +-- | Types a container as having a minimum length of zero. This is useful when combined with other 'MinLen' +-- functions that increase the size of the container. +-- +-- ==== __Examples__ +-- +-- @ +-- > 1 \`mlcons` 'toMinLenZero' [] +-- 'MinLen' {unMinLen = [1]} +-- @ +toMinLenZero :: (MonoFoldable mono) => mono -> MinLen Zero mono +toMinLenZero = MinLen + +-- | Attempts to add a 'MinLen' constraint to a monomorphic container. +-- +-- ==== __Examples__ +-- +-- @ +-- > let xs = 'toMinLen' [1,2,3] :: 'Maybe' ('MinLen' ('Succ' 'Zero') ['Int']) +-- > xs +-- 'Just' ('MinLen' {unMinLen = [1,2,3]}) +-- +-- > :i xs +-- xs :: 'Maybe' ('MinLen' ('Succ' 'Zero') ['Int']) +-- @ +-- +-- @ +-- > 'toMinLen' [] :: 'Maybe' ('MinLen' ('Succ' 'Zero') ['Int']) +-- 'Nothing' +-- @ +toMinLen :: (MonoFoldable mono, TypeNat nat) => mono -> Maybe (MinLen nat mono) +toMinLen mono = + case ocompareLength mono (toValueNat nat :: Int) of + LT -> Nothing + _ -> Just res' + where + nat = natProxy res' + res' = MinLen mono + +-- | __Unsafe__ +-- +-- Although this function itself cannot cause a segfault, it breaks the +-- safety guarantees of 'MinLen' and can lead to a segfault when using +-- otherwise safe functions. +-- +-- ==== __Examples__ +-- +-- @ +-- > let xs = 'unsafeToMinLen' [] :: 'MinLen' ('Succ' 'Zero') ['Int'] +-- > 'olength' xs +-- 0 +-- > 'head' xs +-- *** Exception: Data.MonoTraversable.headEx: empty +-- @ +unsafeToMinLen :: mono -> MinLen nat mono +unsafeToMinLen = MinLen + +infixr 5 `mlcons` + +-- | Adds an element to the front of a list, increasing its minimum length by 1. +-- +-- ==== __Examples__ +-- +-- @ +-- > let xs = 'unsafeToMinLen' [1,2,3] :: 'MinLen' ('Succ' 'Zero') ['Int'] +-- > 0 \`mlcons` xs +-- 'MinLen' {unMinLen = [0,1,2,3]} +-- @ +mlcons :: IsSequence seq => Element seq -> MinLen nat seq -> MinLen (Succ nat) seq +mlcons e (MinLen seq) = MinLen (cons e seq) +{-# INLINE mlcons #-} + +-- | Concatenate two sequences, adding their minimum lengths together. +-- +-- ==== __Examples__ +-- +-- @ +-- > let xs = 'unsafeToMinLen' [1,2,3] :: 'MinLen' ('Succ' 'Zero') ['Int'] +-- > xs \`mlappend` xs +-- 'MinLen' {unMinLen = [1,2,3,1,2,3]} +-- @ +mlappend :: IsSequence seq => MinLen x seq -> MinLen y seq -> MinLen (AddNat x y) seq +mlappend (MinLen x) (MinLen y) = MinLen (x `mappend` y) +{-# INLINE mlappend #-} + +-- | Return the first element of a monomorphic container. +-- +-- Safe version of 'headEx', only works on monomorphic containers wrapped in a +-- @'MinLen' ('Succ' nat)@. +head :: MonoFoldable mono => MinLen (Succ nat) mono -> Element mono +head = headEx . unMinLen +{-# INLINE head #-} + +-- | Return the last element of a monomorphic container. +-- +-- Safe version of 'lastEx', only works on monomorphic containers wrapped in a +-- @'MinLen' ('Succ' nat)@. +last :: MonoFoldable mono => MinLen (Succ nat) mono -> Element mono +last = lastEx . unMinLen +{-# INLINE last #-} + +-- | Returns all but the first element of a sequence, reducing its 'MinLen' by 1. +-- +-- Safe, only works on sequences wrapped in a @'MinLen' ('Succ' nat)@. +-- +-- ==== __Examples__ +-- +-- @ +-- > let xs = 'toMinLen' [1,2,3] :: 'Maybe' ('MinLen' ('Succ' 'Zero') ['Int']) +-- > 'fmap' 'tailML' xs +-- 'Just' ('MinLen' {unMinLen = [2,3]}) +-- @ +tailML :: IsSequence seq => MinLen (Succ nat) seq -> MinLen nat seq +tailML = MinLen . tailEx . unMinLen + +-- | Returns all but the last element of a sequence, reducing its 'MinLen' by 1. +-- +-- Safe, only works on sequences wrapped in a @'MinLen' ('Succ' nat)@. +-- +-- ==== __Examples__ +-- +-- @ +-- > let xs = 'toMinLen' [1,2,3] :: 'Maybe' ('MinLen' ('Succ' 'Zero') ['Int']) +-- > 'fmap' 'initML' xs +-- 'Just' ('MinLen' {unMinLen = [1,2]}) +-- @ +initML :: IsSequence seq => MinLen (Succ nat) seq -> MinLen nat seq +initML = MinLen . initEx . unMinLen + +-- | Joins two semigroups, keeping the larger 'MinLen' of the two. +-- +-- ==== __Examples__ +-- +-- @ +-- > let xs = 'unsafeToMinLen' [1] :: 'MinLen' ('Succ' 'Zero') ['Int'] +-- > let ys = xs \`mlunion` xs +-- > ys +-- 'MinLen' {unMinLen = [1,1]} +-- +-- > :i ys +-- ys :: 'MinLen' ('Succ' 'Zero') ['Int'] +-- @ +mlunion :: (Semigroup mono, GrowingAppend mono) => MinLen x mono -> MinLen y mono -> MinLen (MaxNat x y) mono +mlunion (MinLen x) (MinLen y) = MinLen (x <> y) + +-- | Map each element of a monomorphic container to a semigroup, and combine the +-- results. +-- +-- Safe version of 'ofoldMap1Ex', only works on monomorphic containers wrapped in a +-- @'MinLen' ('Succ' nat)@. +-- +-- ==== __Examples__ +-- +-- @ +-- > let xs = ("hello", 1 :: 'Integer') \`mlcons` (" world", 2) \`mlcons` ('toMinLenZero' []) +-- > 'ofoldMap1' 'fst' xs +-- "hello world" +-- @ +ofoldMap1 :: (MonoFoldable mono, Semigroup m) => (Element mono -> m) -> MinLen (Succ nat) mono -> m +ofoldMap1 f = ofoldMap1Ex f . unMinLen +{-# INLINE ofoldMap1 #-} + +-- | Join a monomorphic container, whose elements are 'Semigroup's, together. +-- +-- Safe, only works on monomorphic containers wrapped in a @'MinLen' ('Succ' nat)@. +-- +-- ==== __Examples__ +-- +-- @ +-- > let xs = "a" \`mlcons` "b" \`mlcons` "c" \`mlcons` ('toMinLenZero' []) +-- > xs +-- 'MinLen' {unMinLen = ["a","b","c"]} +-- +-- > 'ofold1' xs +-- "abc" +-- @ +ofold1 :: (MonoFoldable mono, Semigroup (Element mono)) => MinLen (Succ nat) mono -> Element mono +ofold1 = ofoldMap1 id +{-# INLINE ofold1 #-} + +-- | Right-associative fold of a monomorphic container with no base element. +-- +-- Safe version of 'ofoldr1Ex', only works on monomorphic containers wrapped in a +-- @'MinLen' ('Succ' nat)@. +-- +-- @'foldr1' f = "Prelude".'Prelude.foldr1' f . 'otoList'@ +-- +-- ==== __Examples__ +-- +-- @ +-- > let xs = "a" \`mlcons` "b" \`mlcons` "c" \`mlcons` ('toMinLenZero' []) +-- > 'ofoldr1' (++) xs +-- "abc" +-- @ +ofoldr1 :: MonoFoldable mono + => (Element mono -> Element mono -> Element mono) + -> MinLen (Succ nat) mono + -> Element mono +ofoldr1 f = ofoldr1Ex f . unMinLen +{-# INLINE ofoldr1 #-} + +-- | Strict left-associative fold of a monomorphic container with no base +-- element. +-- +-- Safe version of 'ofoldl1Ex'', only works on monomorphic containers wrapped in a +-- @'MinLen' ('Succ' nat)@. +-- +-- @'foldl1'' f = "Prelude".'Prelude.foldl1'' f . 'otoList'@ +-- +-- ==== __Examples__ +-- +-- @ +-- > let xs = "a" \`mlcons` "b" \`mlcons` "c" \`mlcons` ('toMinLenZero' []) +-- > 'ofoldl1'' (++) xs +-- "abc" +-- @ +ofoldl1' :: MonoFoldable mono + => (Element mono -> Element mono -> Element mono) + -> MinLen (Succ nat) mono + -> Element mono +ofoldl1' f = ofoldl1Ex' f . unMinLen +{-# INLINE ofoldl1' #-} + +-- | Get the maximum element of a monomorphic container. +-- +-- Safe version of 'maximumEx', only works on monomorphic containers wrapped in a +-- @'MinLen' ('Succ' nat)@. +-- +-- ==== __Examples__ +-- +-- @ +-- > let xs = 'toMinLen' [1,2,3] :: 'Maybe' ('MinLen' ('Succ' 'Zero') ['Int']) +-- > 'fmap' 'maximum' xs +-- 'Just' 3 +-- @ +maximum :: (MonoFoldable mono, Ord (Element mono)) + => MinLen (Succ nat) mono + -> Element mono +maximum = maximumEx . unMinLen +{-# INLINE maximum #-} + +-- | Get the minimum element of a monomorphic container. +-- +-- Safe version of 'minimumEx', only works on monomorphic containers wrapped in a +-- @'MinLen' ('Succ' nat)@. +-- +-- ==== __Examples__ +-- +-- @ +-- > let xs = 'toMinLen' [1,2,3] :: 'Maybe' ('MinLen' ('Succ' 'Zero') ['Int']) +-- > 'fmap' 'minimum' xs +-- 'Just' 1 +-- @ +minimum :: (MonoFoldable mono, Ord (Element mono)) + => MinLen (Succ nat) mono + -> Element mono +minimum = minimumEx . unMinLen +{-# INLINE minimum #-} + +-- | Get the maximum element of a monomorphic container, +-- using a supplied element ordering function. +-- +-- Safe version of 'maximumByEx', only works on monomorphic containers wrapped in a +-- @'MinLen' ('Succ' nat)@. +maximumBy :: MonoFoldable mono + => (Element mono -> Element mono -> Ordering) + -> MinLen (Succ nat) mono + -> Element mono +maximumBy cmp = maximumByEx cmp . unMinLen +{-# INLINE maximumBy #-} + +-- | Get the minimum element of a monomorphic container, +-- using a supplied element ordering function. +-- +-- Safe version of 'minimumByEx', only works on monomorphic containers wrapped in a +-- @'MinLen' ('Succ' nat)@. +minimumBy :: MonoFoldable mono + => (Element mono -> Element mono -> Ordering) + -> MinLen (Succ nat) mono + -> Element mono +minimumBy cmp = minimumByEx cmp . unMinLen +{-# INLINE minimumBy #-} + +-- | 'oextract' is 'head'. +-- +-- For @'oextend' f@, the new 'mono' is populated by applying @f@ to +-- successive 'tail's of the original 'mono'. +-- +-- For example, for @'MinLen' ('Succ' 'Zero') ['Int']@, or +-- @'NonNull' ['Int']@: +-- +-- @ +-- 'oextend' f [1,2,3,4,5] = [ f [1, 2, 3, 4, 5] +-- , f [2, 3, 4, 5] +-- , f [3, 4, 5] +-- , f [4, 5] +-- , f [5] +-- ] +-- @ +-- +-- Meant to be a direct analogy to the instance for 'NonEmpty' @a@. +-- +instance IsSequence mono + => MonoComonad (MinLen (Succ Zero) mono) where + oextract = head + oextend f (MinLen mono) = MinLen + . flip evalState mono + . ofor mono + . const + . state + $ \mono' -> (f (MinLen mono'), tailEx mono')