{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
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)
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 (..))
import Data.GrowingAppend
import Control.Monad (liftM)
-- $peanoNumbers
-- <https://wiki.haskell.org/Peano_numbers Peano numbers> 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 <https://wiki.haskell.org/Peano_numbers Peano number>,
-- 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 <https://wiki.haskell.org/Phantom_type phantom type>,
-- 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, Functor)
type instance Element (MinLen nat mono) = Element mono
deriving instance MonoFunctor mono => MonoFunctor (MinLen nat mono)
deriving instance MonoFoldable mono => MonoFoldable (MinLen nat mono)
deriving instance MonoFoldableOrd mono => MonoFoldableOrd (MinLen nat mono)
instance MonoTraversable mono => MonoTraversable (MinLen nat mono) where
otraverse f (MinLen x) = fmap MinLen (otraverse f x)
{-# INLINE otraverse #-}
omapM f (MinLen x) = liftM MinLen (omapM f x)
{-# INLINE omapM #-}
deriving instance GrowingAppend mono => GrowingAppend (MinLen nat mono)
instance 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 = fmap $ intersperse e
reverse = fmap reverse
find f = find f . unMinLen
cons x = fmap $ cons x
snoc xs x = fmap (flip snoc x) xs
sortBy f = fmap $ 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 :: 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 :: MonoFoldableOrd 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 :: MonoFoldableOrd 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 #-}