{-# LANGUAGE Trustworthy #-} -- can't use Safe due to IsList instance
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE OverloadedLists #-}

-- {-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : Control.Monad.List.NonEmpty.Exotic
-- Description : Non-standard monads on the non-empty list functor
-- Copyright   : (c) Dylan McDermott, Maciej Piróg, Tarmo Uustalu, 2020
-- License     : MIT
-- Maintainer  : maciej.adam.pirog@gmail.com
-- Stability   : experimental
-- Portability : portable
--
-- The usual list monad is only one of infinitely many ways to turn
-- the 'NonEmpty.NonEmpty' (list) functor into a monad. This module
-- collects a number of such exotic "non-empty list monads".  Most of
-- them have been introduced in the paper [Degrading
-- Lists](https://raw.githubusercontent.com/maciejpirog/exotic-list-monads/master/degrading-lists.pdf)
-- by Dylan McDermott, Maciej Piróg, Tarmo Uustalu (PPDP 2020).
--
-- __Notes:__
--
-- * Types marked with \"(?)\" have not been formally verified to be
-- monads (yet),  though they were thoroughly tested with billions of
-- QuickCheck tests.
--
-- * Monads in this module are presented in terms of @join@ rather
-- than '>>=', while 'return' is singleton, unless stated otherwise
-- for a particular monad (e.g., 'HeadTails', 'HeadsTail', or
-- 'IdXList').
--
-- * For readability, code snippets in this documentation assume the
-- @OverloadedLists@ and @OverloadedStrings@ extensions, which allow
-- us to omit some @newtype@ constructors. Example definitions of
-- joins of monads always skip the @newtype@ constructors, that is,
-- assume '>>=' is always defined as follows for a particular local
-- @join@.
--
-- @
-- m '>>=' f = 'wrap' $ join $ 'fmap' ('unwrap' . f) $ 'unwrap' m
--  where
--   join = ...
-- @
--
-- * Sometimes it is more readable to define the join in terms of
-- possibly-empty lists. In such a case, we call the local function
-- @joinList@:
--
-- @
-- m '>>=' f = 'wrap' $ 'GHC.Exts.fromList' $ joinList $ 'map' ('GHC.Exts.toList' . 'unwrap' . f) $ 'GHC.Exts.toList' $ 'unwrap' m
--  where
--   joinList = ...
-- @
--
-- 
-- * The definitions of monads are optimized for readability and not
-- run-time performance. This is because the monads in this module
-- don't seem to be of any practical use, they are more of a
-- theoretical curiosity.


module Control.Monad.List.NonEmpty.Exotic
  (
  -- * Non-empty monads in general

    IsNonEmpty(..)
  , NonEmptyMonad(..)
    
  -- ** More on non-empty lists

  , isSingle
  , splitSnoc
  , nonEmptyConcat
  , (+++)
  , nonEmptyAll
  , nonEmptyAny
    
  -- * Monads from magmas

  -- $magmas
  
  , Magma(..)
  , FreeRBM(..)

  -- ** The Keeper monad

  , XY
  , Keeper(..)
  
  -- ** The Non-Empty Discrete Hybrid monad

  , YZ
  , DiscreteHybridNE(..)
  
  -- ** The Non-Empty Discrete Op-Hybrid monad

  , XZ
  , OpDiscreteHybridNE(..)

  -- ** The Non-Empty Maze Walk monad

  , PalindromeMagma
  , MazeWalkNE(..)

  -- ** The Non-Empty Stutter monad

  , StutterMagma
  , StutterNE(..)
  
  -- * Other monads with finite presentation

  -- $others
  
  -- ** The Head-Tails monad

  , HeadTailTail(..)
  , HeadTails(..)
  , foldHeadTails

  -- ** The Heads-Tail monad

  , HeadHeadTail(..)
  , HeadsTail(..)
  , foldHeadsTail
  
  -- * Other monads

  -- ** The ΑΩ monad (?)

  , AlphaOmega(..)

  -- * Constructions on non-empty monads

  -- ** The dual non-empty list monad

  , DualNonEmptyMonad(..)

  -- ** The @Identity@ ⨉ @List@ monad

  , IdXList(..)

  -- ** Short-front monads

  , HasShortFront
  , ShortFront(..)

  -- ** Short-rear monads

  , HasShortRear
  , ShortRear(..)
  
  ) where

import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Prelude hiding ((<>))
import Control.Monad (ap, join)
import Data.Kind (Type)
import GHC.Exts (IsList(..), IsString(..), Constraint)
import GHC.TypeLits
import Data.Proxy
import qualified Data.Semigroup (Semigroup)
import Control.Monad.List.Exotic (ListMonad, palindromize)
import qualified Control.Monad.List.Exotic as List.Exotic (ListMonad(..))

---------------------------
-- Non-empty list monads --
---------------------------

-- | This class collects types that are isomorphic to non-empty
-- lists. It mimics the 'GHC.Exts.IsList' class.
class IsNonEmpty l where
  type ItemNE l
  fromNonEmpty :: NonEmpty (ItemNE l) -> l
  toNonEmpty   :: l -> NonEmpty (ItemNE l)

instance IsNonEmpty (NonEmpty a) where
  type ItemNE (NonEmpty a) = a
  fromNonEmpty :: NonEmpty (ItemNE (NonEmpty a)) -> NonEmpty a
fromNonEmpty = forall a. a -> a
id
  toNonEmpty :: NonEmpty a -> NonEmpty (ItemNE (NonEmpty a))
toNonEmpty   = forall a. a -> a
id

-- | In this module, a \"non-empty monad\" is a monad in which the
-- underlying functor is isomorphic to 'Data.List.NonEmpty.NonEmpty'.
class (Monad m) => NonEmptyMonad m where

  wrap   :: NonEmpty a -> m a
  default wrap   :: (IsNonEmpty (m a), ItemNE (m a) ~ a) => NonEmpty a -> m a
  wrap = forall l. IsNonEmpty l => NonEmpty (ItemNE l) -> l
fromNonEmpty
  
  unwrap :: m a -> NonEmpty a
  default unwrap :: (IsNonEmpty (m a), ItemNE (m a) ~ a) => m a -> NonEmpty a
  unwrap = forall l. IsNonEmpty l => l -> NonEmpty (ItemNE l)
toNonEmpty

instance NonEmptyMonad NonEmpty

-- | Split a non empty list to reveal the last element.
splitSnoc :: NonEmpty a -> ([a], a)
splitSnoc :: forall a. NonEmpty a -> ([a], a)
splitSnoc (a
x :| []) = ([], a
x)
splitSnoc (a
x :| [a]
xs) = (a
x forall a. a -> [a] -> [a]
: forall a. [a] -> [a]
init [a]
xs, forall a. [a] -> a
last [a]
xs)

-- | Check if a list is a singleton.
isSingle :: NonEmpty a -> Bool
isSingle :: forall a. NonEmpty a -> Bool
isSingle (a
_ :| []) = Bool
True
isSingle NonEmpty a
_         = Bool
False

-- | 'concat' for non-empty lists.
nonEmptyConcat :: NonEmpty (NonEmpty a) -> NonEmpty a
nonEmptyConcat :: forall a. NonEmpty (NonEmpty a) -> NonEmpty a
nonEmptyConcat = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join

-- | '++' for non-empty lists.
(+++) :: NonEmpty a -> NonEmpty a -> NonEmpty a
NonEmpty a
a +++ :: forall a. NonEmpty a -> NonEmpty a -> NonEmpty a
+++ NonEmpty a
b = forall a. NonEmpty (NonEmpty a) -> NonEmpty a
nonEmptyConcat [NonEmpty a
a, NonEmpty a
b]  -- OverloadedLists

-- | 'all' for non-empty lists.
nonEmptyAll :: (a -> Bool) -> NonEmpty a -> Bool
nonEmptyAll :: forall a. (a -> Bool) -> NonEmpty a -> Bool
nonEmptyAll a -> Bool
p (a
x :| [a]
xs) = a -> Bool
p a
x Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all a -> Bool
p [a]
xs

-- | 'any' for non-empty lists.
nonEmptyAny :: (a -> Bool) -> NonEmpty a -> Bool
nonEmptyAny :: forall a. (a -> Bool) -> NonEmpty a -> Bool
nonEmptyAny a -> Bool
p (a
x :| [a]
xs) = a -> Bool
p a
x Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any a -> Bool
p [a]
xs

------------
-- Magmas --
------------

-- $magmas
--
-- This section contains monads that come about from free algebras of
-- theories with one binary operation, that is, subcalsses of 'Magma'
-- with no additional methods, but additional equations.

-- | A very simple algebraic theory with one binary operations and no
-- equations.
class Magma a where
  (<>) :: a -> a -> a

-- | The name of the class stands for __free right-braketed__
-- (subclass of) __magma__. (compare
-- 'Control.Monad.List.Exotic.FreeRBPM' for more detailed
-- explanation).
--
-- We consider theories @c@ with one equation of the following shape:
--
-- @
-- (x '<>' y) '<>' z  ==  ...
-- @
--
-- and normal forms of the following shape:
--
-- @
-- x '<>' (y '<>' ( ... (z '<>' t) ... ))
-- @
--
-- An instance @FreeRBM m c@ means that the monad @m@ comes about from
-- free algebras of the theory @c@. For such monads and theories, we
-- can define the following function:
--
-- @
-- foldRBM f (toNonEmpty -> toList -> xs) = foldr1 (<>) (map f xs)
-- @
--
-- which is the unique lifting of an interpretation of generators to a
-- homomorphism (between algebras of this theory) from the list monad
-- to any algebra (an instance) of @c@.
--
-- Note that the default definition of 'foldRBM' is always the right
-- one for right-bracketed subclasses of 'Magma', so it is
-- enough to declare the relationship, for example:
--
-- @
-- instance FreeRBM 'NonEmpty' 'Data.Semigroup.Semigroup'
-- @
class (NonEmptyMonad m) => FreeRBM m (c :: Type -> Constraint) | m -> c where
  foldRBM :: (Magma a, c a) => (x -> a) -> m x -> a
  foldRBM x -> a
f (forall (m :: * -> *) a. NonEmptyMonad m => m a -> NonEmpty a
unwrap -> forall l. IsList l => l -> [Item l]
toList -> [Item (NonEmpty x)]
xs) = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall a. Magma a => a -> a -> a
(<>) (forall a b. (a -> b) -> [a] -> [b]
map x -> a
f [Item (NonEmpty x)]
xs)

instance FreeRBM NonEmpty Data.Semigroup.Semigroup

----------------------
-- The Keeper monad --
----------------------

-- | Instances should satisfy the following equation:
--
-- @
-- (x '<>' y) '<>' z  ==  x '<>' y
-- @
class (Magma a) => XY a

-- | The keeper monad arises from free 'XY' magmas. Its join (in terms
-- of @joinList@) is given as follows:
--
-- @
-- joinList xss = map head (takeWhile 'Control.Monad.List.Exotic.isSingle' (init xss))
--                 ++ head (dropWhile 'Control.Monad.List.Exotic.isSingle' (init xss) ++ [last xss])
-- @
--
-- Examples:
--
-- >>> toList $ unwrap (join ["a", "b", "c", "hello", "there"] :: Keeper Char)
-- "abchello"
-- >>> toList $ unwrap (join ["a", "b", "c", "hello"] :: Keeper Char)
-- "abchello"
newtype Keeper a = Keeper { forall a. Keeper a -> NonEmpty a
unKeeper :: NonEmpty a }
 deriving (forall a b. a -> Keeper b -> Keeper a
forall a b. (a -> b) -> Keeper a -> Keeper b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Keeper b -> Keeper a
$c<$ :: forall a b. a -> Keeper b -> Keeper a
fmap :: forall a b. (a -> b) -> Keeper a -> Keeper b
$cfmap :: forall a b. (a -> b) -> Keeper a -> Keeper b
Functor, Int -> Keeper a -> ShowS
forall a. Show a => Int -> Keeper a -> ShowS
forall a. Show a => [Keeper a] -> ShowS
forall a. Show a => Keeper a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Keeper a] -> ShowS
$cshowList :: forall a. Show a => [Keeper a] -> ShowS
show :: Keeper a -> String
$cshow :: forall a. Show a => Keeper a -> String
showsPrec :: Int -> Keeper a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Keeper a -> ShowS
Show, Keeper a -> Keeper a -> Bool
forall a. Eq a => Keeper a -> Keeper a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Keeper a -> Keeper a -> Bool
$c/= :: forall a. Eq a => Keeper a -> Keeper a -> Bool
== :: Keeper a -> Keeper a -> Bool
$c== :: forall a. Eq a => Keeper a -> Keeper a -> Bool
Eq)

instance Applicative Keeper where
  pure :: forall a. a -> Keeper a
pure a
a = forall a. NonEmpty a -> Keeper a
Keeper forall a b. (a -> b) -> a -> b
$ [a
a]  -- OverloadedLists
  <*> :: forall a b. Keeper (a -> b) -> Keeper a -> Keeper b
(<*>)  = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad Keeper where
  Keeper NonEmpty a
xs >>= :: forall a b. Keeper a -> (a -> Keeper b) -> Keeper b
>>= a -> Keeper b
f =
    forall a. NonEmpty a -> Keeper a
Keeper forall a b. (a -> b) -> a -> b
$ forall {l}. IsList l => NonEmpty (NonEmpty (Item l)) -> l
join forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (forall a. Keeper a -> NonEmpty a
unKeeper forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Keeper b
f) NonEmpty a
xs
   where
    join :: NonEmpty (NonEmpty (Item l)) -> l
join (forall a. NonEmpty a -> ([a], a)
splitSnoc -> ([NonEmpty (Item l)]
xss, NonEmpty (Item l)
xs)) = forall l. IsList l => [Item l] -> l
fromList forall a b. (a -> b) -> a -> b
$
      forall a b. (a -> b) -> [a] -> [b]
map forall a. NonEmpty a -> a
NonEmpty.head (forall a. (a -> Bool) -> [a] -> [a]
takeWhile forall a. NonEmpty a -> Bool
isSingle [NonEmpty (Item l)]
xss)
       forall a. [a] -> [a] -> [a]
++ forall l. IsList l => l -> [Item l]
toList (forall a. [a] -> a
head (forall a. (a -> Bool) -> [a] -> [a]
dropWhile forall a. NonEmpty a -> Bool
isSingle [NonEmpty (Item l)]
xss forall a. [a] -> [a] -> [a]
++ [NonEmpty (Item l)
xs])) -- OverloadedLists

instance IsNonEmpty (Keeper a) where
  type ItemNE (Keeper a) = a
  fromNonEmpty :: NonEmpty (ItemNE (Keeper a)) -> Keeper a
fromNonEmpty = forall a. NonEmpty a -> Keeper a
Keeper
  toNonEmpty :: Keeper a -> NonEmpty (ItemNE (Keeper a))
toNonEmpty = forall a. Keeper a -> NonEmpty a
unKeeper

instance NonEmptyMonad Keeper

instance Magma (Keeper a) where
  Keeper a
m <> :: Keeper a -> Keeper a -> Keeper a
<> Keeper a
t = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> Keeper a
Keeper forall a b. (a -> b) -> a -> b
$ [Keeper a
m, Keeper a
t]

instance XY (Keeper a)

instance FreeRBM Keeper XY

-- The following two are needed for examples in the docs:

instance IsList (Keeper a) where
  type Item (Keeper a) = a
  fromList :: [Item (Keeper a)] -> Keeper a
fromList = forall l. IsNonEmpty l => NonEmpty (ItemNE l) -> l
fromNonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => [Item l] -> l
fromList
  toList :: Keeper a -> [Item (Keeper a)]
toList = forall l. IsList l => l -> [Item l]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsNonEmpty l => l -> NonEmpty (ItemNE l)
toNonEmpty

instance IsString (Keeper Char) where
  fromString :: String -> Keeper Char
fromString = forall l. IsList l => [Item l] -> l
fromList

-----------------------------------------
-- The Non-Empty Discrete Hybrid monad --
-----------------------------------------

-- | Instances should satisfy the following equation:
--
-- @
-- (x '<>' y) '<>' z  ==  y '<>' z
-- @
class (Magma a) => YZ a

-- | The non-empty discrete hybrid monad arises from free 'YZ'
-- magmas. Its join (in terms of @joinList@) can be given as follows:
--
-- @
-- joinList xss = map last (init xss) ++ last xss
-- @
--
-- See the possibly-empty version
-- ('Control.Monad.List.Exotic.DiscreteHybrid') for more details.
newtype DiscreteHybridNE a =
  DiscreteHybridNE { forall a. DiscreteHybridNE a -> NonEmpty a
unDiscreteHybridNE :: NonEmpty a }
 deriving (forall a b. a -> DiscreteHybridNE b -> DiscreteHybridNE a
forall a b. (a -> b) -> DiscreteHybridNE a -> DiscreteHybridNE b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> DiscreteHybridNE b -> DiscreteHybridNE a
$c<$ :: forall a b. a -> DiscreteHybridNE b -> DiscreteHybridNE a
fmap :: forall a b. (a -> b) -> DiscreteHybridNE a -> DiscreteHybridNE b
$cfmap :: forall a b. (a -> b) -> DiscreteHybridNE a -> DiscreteHybridNE b
Functor, Int -> DiscreteHybridNE a -> ShowS
forall a. Show a => Int -> DiscreteHybridNE a -> ShowS
forall a. Show a => [DiscreteHybridNE a] -> ShowS
forall a. Show a => DiscreteHybridNE a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DiscreteHybridNE a] -> ShowS
$cshowList :: forall a. Show a => [DiscreteHybridNE a] -> ShowS
show :: DiscreteHybridNE a -> String
$cshow :: forall a. Show a => DiscreteHybridNE a -> String
showsPrec :: Int -> DiscreteHybridNE a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> DiscreteHybridNE a -> ShowS
Show, DiscreteHybridNE a -> DiscreteHybridNE a -> Bool
forall a. Eq a => DiscreteHybridNE a -> DiscreteHybridNE a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DiscreteHybridNE a -> DiscreteHybridNE a -> Bool
$c/= :: forall a. Eq a => DiscreteHybridNE a -> DiscreteHybridNE a -> Bool
== :: DiscreteHybridNE a -> DiscreteHybridNE a -> Bool
$c== :: forall a. Eq a => DiscreteHybridNE a -> DiscreteHybridNE a -> Bool
Eq)

instance Applicative DiscreteHybridNE where
  pure :: forall a. a -> DiscreteHybridNE a
pure a
a = forall a. NonEmpty a -> DiscreteHybridNE a
DiscreteHybridNE forall a b. (a -> b) -> a -> b
$ [a
a]  -- OverloadedLists
  <*> :: forall a b.
DiscreteHybridNE (a -> b)
-> DiscreteHybridNE a -> DiscreteHybridNE b
(<*>)  = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad DiscreteHybridNE where
  DiscreteHybridNE NonEmpty a
xs >>= :: forall a b.
DiscreteHybridNE a
-> (a -> DiscreteHybridNE b) -> DiscreteHybridNE b
>>= a -> DiscreteHybridNE b
f =
    forall a. NonEmpty a -> DiscreteHybridNE a
DiscreteHybridNE forall a b. (a -> b) -> a -> b
$ forall {l}. IsList l => NonEmpty (NonEmpty (Item l)) -> l
join forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (forall a. DiscreteHybridNE a -> NonEmpty a
unDiscreteHybridNE forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DiscreteHybridNE b
f) NonEmpty a
xs
   where
    join :: NonEmpty (NonEmpty (Item l)) -> l
join (forall a. NonEmpty a -> ([a], a)
splitSnoc -> ([NonEmpty (Item l)]
xss, NonEmpty (Item l)
xs)) = forall l. IsList l => [Item l] -> l
fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a. NonEmpty a -> a
NonEmpty.last [NonEmpty (Item l)]
xss forall a. [a] -> [a] -> [a]
++ forall l. IsList l => l -> [Item l]
toList NonEmpty (Item l)
xs)
  
instance IsNonEmpty (DiscreteHybridNE a) where
  type ItemNE (DiscreteHybridNE a) = a
  fromNonEmpty :: NonEmpty (ItemNE (DiscreteHybridNE a)) -> DiscreteHybridNE a
fromNonEmpty = forall a. NonEmpty a -> DiscreteHybridNE a
DiscreteHybridNE
  toNonEmpty :: DiscreteHybridNE a -> NonEmpty (ItemNE (DiscreteHybridNE a))
toNonEmpty = forall a. DiscreteHybridNE a -> NonEmpty a
unDiscreteHybridNE

instance NonEmptyMonad DiscreteHybridNE

instance Magma (DiscreteHybridNE a) where
  DiscreteHybridNE a
m <> :: DiscreteHybridNE a -> DiscreteHybridNE a -> DiscreteHybridNE a
<> DiscreteHybridNE a
t = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> DiscreteHybridNE a
DiscreteHybridNE forall a b. (a -> b) -> a -> b
$ [DiscreteHybridNE a
m, DiscreteHybridNE a
t]

instance YZ (DiscreteHybridNE a)

instance FreeRBM DiscreteHybridNE YZ

--------------------------------------------
-- The Non-Empty Discrete Op-Hybrid monad --
-------------------------------------------

-- | Instances should satisfy the following equation:
--
-- @
-- (x '<>' y) '<>' z  ==  x '<>' z
-- @
class (Magma a) => XZ a

-- | The non-empty discrete op-hybrid monad arises from free 'XZ'
-- magmas. It is dual to the 'DiscreteHybridNE' monad (but in a
-- different dimension than 'DualNonEmptyMonad'). Its join (in terms
-- of @joinList@) can be given as follows:
--
-- @
-- joinList xss = map head (init xss) ++ last xss
-- @
--
-- Examples:
--
-- >>> toList $ unwrap (join ["John", "Ronald", "Reuel", "Tolkien"] :: OpDiscreteHybridNE Char)
-- "JRRTolkien"
--
-- Surprisingly, while the 'DiscreteHybridNE' monad has a counterpart
-- for possibly-empty lists
-- ('Control.Monad.List.Exotic.DiscreteHybrid'), the would-be
-- counterpart of @OpDiscreteHybridNE@ obtained by taking first
-- elements in the init is __not__ a monad.
newtype OpDiscreteHybridNE a =
  OpDiscreteHybridNE { forall a. OpDiscreteHybridNE a -> NonEmpty a
unOpDiscreteHybridNE :: NonEmpty a }
 deriving (forall a b. a -> OpDiscreteHybridNE b -> OpDiscreteHybridNE a
forall a b.
(a -> b) -> OpDiscreteHybridNE a -> OpDiscreteHybridNE b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> OpDiscreteHybridNE b -> OpDiscreteHybridNE a
$c<$ :: forall a b. a -> OpDiscreteHybridNE b -> OpDiscreteHybridNE a
fmap :: forall a b.
(a -> b) -> OpDiscreteHybridNE a -> OpDiscreteHybridNE b
$cfmap :: forall a b.
(a -> b) -> OpDiscreteHybridNE a -> OpDiscreteHybridNE b
Functor, Int -> OpDiscreteHybridNE a -> ShowS
forall a. Show a => Int -> OpDiscreteHybridNE a -> ShowS
forall a. Show a => [OpDiscreteHybridNE a] -> ShowS
forall a. Show a => OpDiscreteHybridNE a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OpDiscreteHybridNE a] -> ShowS
$cshowList :: forall a. Show a => [OpDiscreteHybridNE a] -> ShowS
show :: OpDiscreteHybridNE a -> String
$cshow :: forall a. Show a => OpDiscreteHybridNE a -> String
showsPrec :: Int -> OpDiscreteHybridNE a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> OpDiscreteHybridNE a -> ShowS
Show, OpDiscreteHybridNE a -> OpDiscreteHybridNE a -> Bool
forall a.
Eq a =>
OpDiscreteHybridNE a -> OpDiscreteHybridNE a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OpDiscreteHybridNE a -> OpDiscreteHybridNE a -> Bool
$c/= :: forall a.
Eq a =>
OpDiscreteHybridNE a -> OpDiscreteHybridNE a -> Bool
== :: OpDiscreteHybridNE a -> OpDiscreteHybridNE a -> Bool
$c== :: forall a.
Eq a =>
OpDiscreteHybridNE a -> OpDiscreteHybridNE a -> Bool
Eq)

instance Applicative OpDiscreteHybridNE where
  pure :: forall a. a -> OpDiscreteHybridNE a
pure a
a = forall a. NonEmpty a -> OpDiscreteHybridNE a
OpDiscreteHybridNE forall a b. (a -> b) -> a -> b
$ [a
a]  -- OverloadedLists
  <*> :: forall a b.
OpDiscreteHybridNE (a -> b)
-> OpDiscreteHybridNE a -> OpDiscreteHybridNE b
(<*>)  = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad OpDiscreteHybridNE where
  OpDiscreteHybridNE NonEmpty a
xs >>= :: forall a b.
OpDiscreteHybridNE a
-> (a -> OpDiscreteHybridNE b) -> OpDiscreteHybridNE b
>>= a -> OpDiscreteHybridNE b
f =
    forall a. NonEmpty a -> OpDiscreteHybridNE a
OpDiscreteHybridNE forall a b. (a -> b) -> a -> b
$ forall {l}. IsList l => NonEmpty (NonEmpty (Item l)) -> l
join forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (forall a. OpDiscreteHybridNE a -> NonEmpty a
unOpDiscreteHybridNE forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> OpDiscreteHybridNE b
f) NonEmpty a
xs
   where
    join :: NonEmpty (NonEmpty (Item l)) -> l
join (forall a. NonEmpty a -> ([a], a)
splitSnoc -> ([NonEmpty (Item l)]
xss, NonEmpty (Item l)
xs)) = forall l. IsList l => [Item l] -> l
fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a. NonEmpty a -> a
NonEmpty.head [NonEmpty (Item l)]
xss forall a. [a] -> [a] -> [a]
++ forall l. IsList l => l -> [Item l]
toList NonEmpty (Item l)
xs)

instance IsNonEmpty (OpDiscreteHybridNE a) where
  type ItemNE (OpDiscreteHybridNE a) = a
  fromNonEmpty :: NonEmpty (ItemNE (OpDiscreteHybridNE a)) -> OpDiscreteHybridNE a
fromNonEmpty = forall a. NonEmpty a -> OpDiscreteHybridNE a
OpDiscreteHybridNE
  toNonEmpty :: OpDiscreteHybridNE a -> NonEmpty (ItemNE (OpDiscreteHybridNE a))
toNonEmpty = forall a. OpDiscreteHybridNE a -> NonEmpty a
unOpDiscreteHybridNE

instance NonEmptyMonad OpDiscreteHybridNE

instance Magma (OpDiscreteHybridNE a) where
  OpDiscreteHybridNE a
m <> :: OpDiscreteHybridNE a
-> OpDiscreteHybridNE a -> OpDiscreteHybridNE a
<> OpDiscreteHybridNE a
t = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> OpDiscreteHybridNE a
OpDiscreteHybridNE forall a b. (a -> b) -> a -> b
$ [OpDiscreteHybridNE a
m, OpDiscreteHybridNE a
t]

instance XZ (OpDiscreteHybridNE a)

instance FreeRBM OpDiscreteHybridNE XZ

-- The following two are needed for examples in the docs:

instance IsList (OpDiscreteHybridNE a) where
  type Item (OpDiscreteHybridNE a) = a
  fromList :: [Item (OpDiscreteHybridNE a)] -> OpDiscreteHybridNE a
fromList = forall l. IsNonEmpty l => NonEmpty (ItemNE l) -> l
fromNonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => [Item l] -> l
fromList
  toList :: OpDiscreteHybridNE a -> [Item (OpDiscreteHybridNE a)]
toList = forall l. IsList l => l -> [Item l]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsNonEmpty l => l -> NonEmpty (ItemNE l)
toNonEmpty

instance IsString (OpDiscreteHybridNE Char) where
  fromString :: String -> OpDiscreteHybridNE Char
fromString = forall l. IsList l => [Item l] -> l
fromList

--------------------------------------------
-- The Non-empty Maze Walk monad --
-------------------------------------------

-- | Instances should satisfy the following equation:
--
-- @
-- (x '<>' y) '<>' z  ==  x '<>' (y '<>' (x '<>' z))
-- @
class (Magma a) => PalindromeMagma a

-- | The non-empty maze walk monad arises from free
-- 'PalindromeMagma'-s. Its join (in terms of @joinList@) can be given
-- as follows:
--
-- @
-- joinList xss = map 'Control.Monad.List.Exotic.palindromize' (init xss) ++ last xss
-- @
--
-- See the possibly-empty version
-- ('Control.Monad.List.Exotic.MazeWalk') for more details.
newtype MazeWalkNE a =
  MazeWalkNE { forall a. MazeWalkNE a -> NonEmpty a
unMazeWalkNE :: NonEmpty a }
 deriving (forall a b. a -> MazeWalkNE b -> MazeWalkNE a
forall a b. (a -> b) -> MazeWalkNE a -> MazeWalkNE b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> MazeWalkNE b -> MazeWalkNE a
$c<$ :: forall a b. a -> MazeWalkNE b -> MazeWalkNE a
fmap :: forall a b. (a -> b) -> MazeWalkNE a -> MazeWalkNE b
$cfmap :: forall a b. (a -> b) -> MazeWalkNE a -> MazeWalkNE b
Functor, Int -> MazeWalkNE a -> ShowS
forall a. Show a => Int -> MazeWalkNE a -> ShowS
forall a. Show a => [MazeWalkNE a] -> ShowS
forall a. Show a => MazeWalkNE a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MazeWalkNE a] -> ShowS
$cshowList :: forall a. Show a => [MazeWalkNE a] -> ShowS
show :: MazeWalkNE a -> String
$cshow :: forall a. Show a => MazeWalkNE a -> String
showsPrec :: Int -> MazeWalkNE a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> MazeWalkNE a -> ShowS
Show, MazeWalkNE a -> MazeWalkNE a -> Bool
forall a. Eq a => MazeWalkNE a -> MazeWalkNE a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MazeWalkNE a -> MazeWalkNE a -> Bool
$c/= :: forall a. Eq a => MazeWalkNE a -> MazeWalkNE a -> Bool
== :: MazeWalkNE a -> MazeWalkNE a -> Bool
$c== :: forall a. Eq a => MazeWalkNE a -> MazeWalkNE a -> Bool
Eq)

instance Applicative MazeWalkNE where
  pure :: forall a. a -> MazeWalkNE a
pure a
a = forall a. NonEmpty a -> MazeWalkNE a
MazeWalkNE forall a b. (a -> b) -> a -> b
$ [a
a]  -- OverloadedLists
  <*> :: forall a b. MazeWalkNE (a -> b) -> MazeWalkNE a -> MazeWalkNE b
(<*>)  = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad MazeWalkNE where
  MazeWalkNE NonEmpty a
xs >>= :: forall a b. MazeWalkNE a -> (a -> MazeWalkNE b) -> MazeWalkNE b
>>= a -> MazeWalkNE b
f =
    forall a. NonEmpty a -> MazeWalkNE a
MazeWalkNE forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty (NonEmpty a) -> NonEmpty a
join forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (forall a. MazeWalkNE a -> NonEmpty a
unMazeWalkNE forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> MazeWalkNE b
f) NonEmpty a
xs
   where
    join :: NonEmpty (NonEmpty a) -> NonEmpty a
    join :: forall a. NonEmpty (NonEmpty a) -> NonEmpty a
join (forall a. NonEmpty a -> ([a], a)
splitSnoc -> ([NonEmpty a]
xss, NonEmpty a
xs)) = forall l. IsList l => [Item l] -> l
fromList forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. [a] -> [a]
palindromize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => l -> [Item l]
toList) [NonEmpty a]
xss forall a. [a] -> [a] -> [a]
++ forall l. IsList l => l -> [Item l]
toList NonEmpty a
xs 

instance IsNonEmpty (MazeWalkNE a) where
  type ItemNE (MazeWalkNE a) = a
  fromNonEmpty :: NonEmpty (ItemNE (MazeWalkNE a)) -> MazeWalkNE a
fromNonEmpty = forall a. NonEmpty a -> MazeWalkNE a
MazeWalkNE
  toNonEmpty :: MazeWalkNE a -> NonEmpty (ItemNE (MazeWalkNE a))
toNonEmpty = forall a. MazeWalkNE a -> NonEmpty a
unMazeWalkNE

instance NonEmptyMonad MazeWalkNE

instance Magma (MazeWalkNE a) where
  MazeWalkNE a
m <> :: MazeWalkNE a -> MazeWalkNE a -> MazeWalkNE a
<> MazeWalkNE a
t = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> MazeWalkNE a
MazeWalkNE forall a b. (a -> b) -> a -> b
$ [MazeWalkNE a
m, MazeWalkNE a
t]

instance PalindromeMagma (MazeWalkNE a)

instance FreeRBM MazeWalkNE PalindromeMagma

---------------------------------
-- The Non-empty Stutter monad --
---------------------------------

-- | Instances should satisfy the following equation:
--
-- @
-- (x '<>' y) '<>' z  ==  'foldr1' ('<>') ('replicate' (n + 2) x)
-- @
class (KnownNat n, Magma a) => StutterMagma n a

-- | The non-empty stutter monad arises from free 'StutterMagma'-s.
-- Its join (in terms of @joinList@) can be given as follows:
--
-- @
-- joinList xss | any (not . 'Control.Monad.List.Exotic.isSingle') (init xss)
--              = map head (takeWhile 'Control.Monad.List.Exotic.isSingle' (init xss))
--                 ++ replicate (n + 2) (head (head (dropWhile 'Control.Monad.List.Exotic.isSingle' (init xss))))
--              | otherwise
--              = map head (init xss) ++ last xss
-- @
--
-- Examples:
--
-- >>> toList $ unwrap (join ["a", "b", "c", "hello", "there"] :: StutterNE 5 Char)
-- "abchhhhhhh"
-- >>> toList $ unwrap (join ["a", "b", "c", "hello"] :: StutterNE 5 Char)
-- "abchello"

newtype StutterNE (n :: Nat) a =
  StutterNE { forall (n :: Nat) a. StutterNE n a -> NonEmpty a
unStutterNE :: NonEmpty a }
 deriving (forall (n :: Nat) a b. a -> StutterNE n b -> StutterNE n a
forall (n :: Nat) a b. (a -> b) -> StutterNE n a -> StutterNE n b
forall a b. a -> StutterNE n b -> StutterNE n a
forall a b. (a -> b) -> StutterNE n a -> StutterNE n b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> StutterNE n b -> StutterNE n a
$c<$ :: forall (n :: Nat) a b. a -> StutterNE n b -> StutterNE n a
fmap :: forall a b. (a -> b) -> StutterNE n a -> StutterNE n b
$cfmap :: forall (n :: Nat) a b. (a -> b) -> StutterNE n a -> StutterNE n b
Functor, Int -> StutterNE n a -> ShowS
forall (n :: Nat) a. Show a => Int -> StutterNE n a -> ShowS
forall (n :: Nat) a. Show a => [StutterNE n a] -> ShowS
forall (n :: Nat) a. Show a => StutterNE n a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StutterNE n a] -> ShowS
$cshowList :: forall (n :: Nat) a. Show a => [StutterNE n a] -> ShowS
show :: StutterNE n a -> String
$cshow :: forall (n :: Nat) a. Show a => StutterNE n a -> String
showsPrec :: Int -> StutterNE n a -> ShowS
$cshowsPrec :: forall (n :: Nat) a. Show a => Int -> StutterNE n a -> ShowS
Show, StutterNE n a -> StutterNE n a -> Bool
forall (n :: Nat) a. Eq a => StutterNE n a -> StutterNE n a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StutterNE n a -> StutterNE n a -> Bool
$c/= :: forall (n :: Nat) a. Eq a => StutterNE n a -> StutterNE n a -> Bool
== :: StutterNE n a -> StutterNE n a -> Bool
$c== :: forall (n :: Nat) a. Eq a => StutterNE n a -> StutterNE n a -> Bool
Eq)

instance (KnownNat n) => Applicative (StutterNE n) where
  pure :: forall a. a -> StutterNE n a
pure a
a = forall (n :: Nat) a. NonEmpty a -> StutterNE n a
StutterNE forall a b. (a -> b) -> a -> b
$ [a
a]  -- OverloadedLists
  <*> :: forall a b. StutterNE n (a -> b) -> StutterNE n a -> StutterNE n b
(<*>)  = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance (KnownNat n) => Monad (StutterNE n) where
  StutterNE NonEmpty a
xs >>= :: forall a b. StutterNE n a -> (a -> StutterNE n b) -> StutterNE n b
>>= a -> StutterNE n b
f =
    forall (n :: Nat) a. NonEmpty a -> StutterNE n a
StutterNE forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty (NonEmpty a) -> NonEmpty a
join forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (forall (n :: Nat) a. StutterNE n a -> NonEmpty a
unStutterNE forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> StutterNE n b
f) NonEmpty a
xs
   where
    join :: NonEmpty (NonEmpty a) -> NonEmpty a
    join :: forall a. NonEmpty (NonEmpty a) -> NonEmpty a
join (forall a. NonEmpty a -> ([a], a)
splitSnoc -> ([NonEmpty a]
xss', NonEmpty a
xs))
      | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> Bool
isSingle) [NonEmpty a]
xss'
      = let n :: Int
n = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy n)
        in  forall l. IsList l => [Item l] -> l
fromList forall a b. (a -> b) -> a -> b
$
              forall a b. (a -> b) -> [a] -> [b]
map forall a. NonEmpty a -> a
NonEmpty.head (forall a. (a -> Bool) -> [a] -> [a]
takeWhile forall a. NonEmpty a -> Bool
isSingle [NonEmpty a]
xss')
               forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
n forall a. Num a => a -> a -> a
+ Int
2)
                  (forall a. NonEmpty a -> a
NonEmpty.head forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile forall a. NonEmpty a -> Bool
isSingle [NonEmpty a]
xss')
      | Bool
otherwise
      = forall l. IsList l => [Item l] -> l
fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. NonEmpty a -> a
NonEmpty.head [NonEmpty a]
xss' forall a. [a] -> [a] -> [a]
++ forall l. IsList l => l -> [Item l]
toList NonEmpty a
xs
      
instance (KnownNat n) => IsNonEmpty (StutterNE n a) where
  type ItemNE (StutterNE n a) = a
  fromNonEmpty :: NonEmpty (ItemNE (StutterNE n a)) -> StutterNE n a
fromNonEmpty = forall (n :: Nat) a. NonEmpty a -> StutterNE n a
StutterNE
  toNonEmpty :: StutterNE n a -> NonEmpty (ItemNE (StutterNE n a))
toNonEmpty = forall (n :: Nat) a. StutterNE n a -> NonEmpty a
unStutterNE

instance (KnownNat n) => NonEmptyMonad (StutterNE n)

instance (KnownNat n) => Magma (StutterNE n a) where
  StutterNE n a
m <> :: StutterNE n a -> StutterNE n a -> StutterNE n a
<> StutterNE n a
t = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) a. NonEmpty a -> StutterNE n a
StutterNE forall a b. (a -> b) -> a -> b
$ [StutterNE n a
m, StutterNE n a
t]

instance (KnownNat n) => StutterMagma n (StutterNE n a)

instance (KnownNat n) => FreeRBM (StutterNE n) (StutterMagma n)

-- The following two are needed for examples in the docs:

instance (KnownNat n) => IsList (StutterNE n a) where
  type Item (StutterNE n a) = a
  fromList :: [Item (StutterNE n a)] -> StutterNE n a
fromList = forall l. IsNonEmpty l => NonEmpty (ItemNE l) -> l
fromNonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => [Item l] -> l
fromList
  toList :: StutterNE n a -> [Item (StutterNE n a)]
toList = forall l. IsList l => l -> [Item l]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsNonEmpty l => l -> NonEmpty (ItemNE l)
toNonEmpty

instance (KnownNat n) => IsString (StutterNE n Char) where
  fromString :: String -> StutterNE n Char
fromString = forall l. IsList l => [Item l] -> l
fromList

--------------------------
-- The Head-Tails monad --
--------------------------

-- $others
--
-- In contrast to the possibly-empty-list case, there are known
-- non-empty monads that arise from algebraic theories, but ones that
-- cannot be presented with one binary operations (as in monads that
-- come about from subclasses of 'Magma').

-- | The head-tail-tail algebra has two operations: unary 'hd'
-- (intuitively, it produces a singleton list with the head of the
-- argument as the element) and ternary 'htt' (intuitively, it
-- produces the concat of the head of the first argument and tails of
-- the other two arguments).
--
-- Instances should satisfy the following equations:
--
-- @
-- x                         ==  'htt' x x ('hd' x)
-- 'hd' ('hd' x)                 ==  'hd' x
-- 'hd' ('htt' x y z)            ==  'hd' x
-- 'htt' x y ('hd' z)            ==  'htt' x y ('hd' y)
-- 'htt' x y ('htt' z v w)       ==  'htt' x y ('htt' y v w)
-- 'htt' x ('hd' y) ('hd' z)       ==  'hd' x
-- 'htt' x ('hd' y) ('htt' z v w)  ==  'htt' x v w
-- 'htt' x ('htt' y z v) w       ==  'htt' x z ('htt' z v w)
-- 'htt' ('hd' x) y z            ==  'htt' x y z
-- 'htt' ('htt' x y z) v w       ==  'htt' x v w
-- @
--
-- Moreover, when read left-to-right they form a terminating and
-- confluent rewriting system with normal forms of the following
-- shape:
--
-- @
-- 'htt' x y $ 'htt' y z $ 'htt' z v $ ... $ 'htt' w t ('hd' t)
-- @
class HeadTailTail a where
  hd  :: a -> a
  htt :: a -> a -> a -> a

-- | The Head-Tails monad arises from free head-tail-tail algebras. Its unit is a dubleton, that is:
--
-- @
-- return x = HeadTails (x :| [x])
-- @
--
-- Its join is defined as:
--
-- @
-- join ((x :| _) :| xss) = x :| concatMap NonEmpty.tail xss
-- @
--
-- For example:
--
-- >>> toList $ unwrap (join ["John", "Paul", "George", "Ringo"] :: HeadTails Char)
-- "Jauleorgeingo"
newtype HeadTails a = HeadTails { forall a. HeadTails a -> NonEmpty a
unHeadTails :: NonEmpty a }
 deriving (forall a b. a -> HeadTails b -> HeadTails a
forall a b. (a -> b) -> HeadTails a -> HeadTails b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> HeadTails b -> HeadTails a
$c<$ :: forall a b. a -> HeadTails b -> HeadTails a
fmap :: forall a b. (a -> b) -> HeadTails a -> HeadTails b
$cfmap :: forall a b. (a -> b) -> HeadTails a -> HeadTails b
Functor, Int -> HeadTails a -> ShowS
forall a. Show a => Int -> HeadTails a -> ShowS
forall a. Show a => [HeadTails a] -> ShowS
forall a. Show a => HeadTails a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HeadTails a] -> ShowS
$cshowList :: forall a. Show a => [HeadTails a] -> ShowS
show :: HeadTails a -> String
$cshow :: forall a. Show a => HeadTails a -> String
showsPrec :: Int -> HeadTails a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> HeadTails a -> ShowS
Show, HeadTails a -> HeadTails a -> Bool
forall a. Eq a => HeadTails a -> HeadTails a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeadTails a -> HeadTails a -> Bool
$c/= :: forall a. Eq a => HeadTails a -> HeadTails a -> Bool
== :: HeadTails a -> HeadTails a -> Bool
$c== :: forall a. Eq a => HeadTails a -> HeadTails a -> Bool
Eq)

instance Applicative HeadTails where
  pure :: forall a. a -> HeadTails a
pure a
a = forall a. NonEmpty a -> HeadTails a
HeadTails forall a b. (a -> b) -> a -> b
$ [a
a,a
a]  -- OverloadedLists
  <*> :: forall a b. HeadTails (a -> b) -> HeadTails a -> HeadTails b
(<*>)  = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad HeadTails where
  HeadTails NonEmpty a
xs >>= :: forall a b. HeadTails a -> (a -> HeadTails b) -> HeadTails b
>>= a -> HeadTails b
f = forall a. NonEmpty a -> HeadTails a
HeadTails forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty (NonEmpty a) -> NonEmpty a
join forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (forall a. HeadTails a -> NonEmpty a
unHeadTails forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> HeadTails b
f) NonEmpty a
xs
   where
    join :: NonEmpty (NonEmpty a) -> NonEmpty a
join ((a
x :| [a]
_) :| [NonEmpty a]
xss) = a
x forall a. a -> [a] -> NonEmpty a
:| forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. NonEmpty a -> [a]
NonEmpty.tail [NonEmpty a]
xss

instance IsNonEmpty (HeadTails a) where
  type ItemNE (HeadTails a) = a
  fromNonEmpty :: NonEmpty (ItemNE (HeadTails a)) -> HeadTails a
fromNonEmpty = forall a. NonEmpty a -> HeadTails a
HeadTails
  toNonEmpty :: HeadTails a -> NonEmpty (ItemNE (HeadTails a))
toNonEmpty = forall a. HeadTails a -> NonEmpty a
unHeadTails

instance NonEmptyMonad HeadTails

instance HeadTailTail (HeadTails a) where
  hd :: HeadTails a -> HeadTails a
hd  HeadTails a
a     = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> HeadTails a
HeadTails [HeadTails a
a]        -- OverloadedLists
  htt :: HeadTails a -> HeadTails a -> HeadTails a -> HeadTails a
htt HeadTails a
a HeadTails a
b HeadTails a
c = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> HeadTails a
HeadTails [HeadTails a
a, HeadTails a
b, HeadTails a
c]  -- OverloadedLists

-- | The 'HeadTails' monad arises from free head-tail-tail algebras,
-- so an interpretation of generators @g@ to a head-tail-tail algebra
-- @a@ can be (uniquely) lifted to a homomorphism between
-- head-tail-tail algebras.
foldHeadTails :: (HeadTailTail a) => (g -> a) -> HeadTails g -> a
foldHeadTails :: forall a g. HeadTailTail a => (g -> a) -> HeadTails g -> a
foldHeadTails g -> a
f (HeadTails (g
x :| [])) = forall a. HeadTailTail a => a -> a
hd (g -> a
f g
x)
foldHeadTails g -> a
f (HeadTails (g
x :| (g
y : [g]
ys))) =
  forall a. HeadTailTail a => a -> a -> a -> a
htt (g -> a
f g
x) (g -> a
f g
y) (forall a g. HeadTailTail a => (g -> a) -> HeadTails g -> a
foldHeadTails g -> a
f forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> HeadTails a
HeadTails forall a b. (a -> b) -> a -> b
$ g
y forall a. a -> [a] -> NonEmpty a
:| [g]
ys)

-- The following two are needed for examples in the docs:

instance IsList (HeadTails a) where
  type Item (HeadTails a) = a
  fromList :: [Item (HeadTails a)] -> HeadTails a
fromList = forall l. IsNonEmpty l => NonEmpty (ItemNE l) -> l
fromNonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => [Item l] -> l
fromList
  toList :: HeadTails a -> [Item (HeadTails a)]
toList = forall l. IsList l => l -> [Item l]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsNonEmpty l => l -> NonEmpty (ItemNE l)
toNonEmpty

instance IsString (HeadTails Char) where
  fromString :: String -> HeadTails Char
fromString = forall l. IsList l => [Item l] -> l
fromList

--------------------------
-- The Heads-Tail monad --
--------------------------

-- | Instances should satisfy the following equations:
--
-- @
-- x                    ==  'ht' x x
-- 'hd'' ('hd'' x)          ==  'hd'' x
-- 'hd'' ('ht' x y)         ==  'hd'' x
-- 'hd'' ('hht' x y z)      ==  'hd'' x
-- 'ht' x ('hd'' y)         ==  'hd'' x
-- 'ht' x ('ht' y z)        ==  'ht' x z
-- 'ht' x ('hht' y z v)     ==  'hht' x z v
-- 'ht' ('hd'' x) y         ==  'ht' x y
-- 'ht' ('ht' x y) z        ==  'ht' x z
-- 'ht' ('hht' x y z) v     ==  'ht' x v
-- 'hht' x y ('hd'' z)      ==  'hd'' x
-- 'hht' x y ('ht' z v)     ==  'hht' x y v
-- 'hht' x y ('hht' z v w)  ==  'hht' x y ('hht' y v w)
-- 'hht' x ('hd'' y) z      ==  'hht' x y z
-- 'hht' x ('ht' y z) v     ==  'hht' x y v
-- 'hht' x ('hht' y z v) w  ==  'hht' x y w
-- 'hht' ('hd'' x) y z      ==  'hht' x y z
-- 'hht' ('ht' x y) z v     ==  'hht' x z v
-- 'hht' ('hht' x y z) v w  ==  'hht' x v w
-- @
--
-- Moreover, when read left-to-right they form a terminating and
-- confluent rewriting system with normal forms of the following
-- shape:
--
-- @
-- 'hd'' x
-- 'ht' x y
-- 'hht' x y $ 'hht' y z $ 'hht' z v $ ... $ 'hht' w t u
-- @
class HeadHeadTail a where
  hd' :: a -> a
  ht  :: a -> a -> a
  hht :: a -> a -> a -> a
  
-- | The Heads-Tail monad arises from free head-head-tail algebras. Its unit is a dubleton, that is:
--
-- @
-- return x = HeadsTail (x :| [x])
-- @
--
-- Its join is defined as:
--
-- @
-- join xss\@('splitSnoc' -> (xss', xs\@(_:|ys)))
--   | 'isSingle' xss || 'isSingle' xs
--   = (NonEmpty.head $ NonEmpty.head xss) :| []
--   | otherwise
--   = fromList $ map NonEmpty.head xss' ++ ys
-- @
--
-- For example:
--
-- >>> toList $ unwrap (join ["John", "Paul", "George", "Ringo"] :: HeadsTail Char)
-- "JPGingo"
newtype HeadsTail a = HeadsTail { forall a. HeadsTail a -> NonEmpty a
unHeadsTail :: NonEmpty a }
 deriving (forall a b. a -> HeadsTail b -> HeadsTail a
forall a b. (a -> b) -> HeadsTail a -> HeadsTail b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> HeadsTail b -> HeadsTail a
$c<$ :: forall a b. a -> HeadsTail b -> HeadsTail a
fmap :: forall a b. (a -> b) -> HeadsTail a -> HeadsTail b
$cfmap :: forall a b. (a -> b) -> HeadsTail a -> HeadsTail b
Functor, Int -> HeadsTail a -> ShowS
forall a. Show a => Int -> HeadsTail a -> ShowS
forall a. Show a => [HeadsTail a] -> ShowS
forall a. Show a => HeadsTail a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HeadsTail a] -> ShowS
$cshowList :: forall a. Show a => [HeadsTail a] -> ShowS
show :: HeadsTail a -> String
$cshow :: forall a. Show a => HeadsTail a -> String
showsPrec :: Int -> HeadsTail a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> HeadsTail a -> ShowS
Show, HeadsTail a -> HeadsTail a -> Bool
forall a. Eq a => HeadsTail a -> HeadsTail a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeadsTail a -> HeadsTail a -> Bool
$c/= :: forall a. Eq a => HeadsTail a -> HeadsTail a -> Bool
== :: HeadsTail a -> HeadsTail a -> Bool
$c== :: forall a. Eq a => HeadsTail a -> HeadsTail a -> Bool
Eq)

instance Applicative HeadsTail where
  pure :: forall a. a -> HeadsTail a
pure a
a = forall a. NonEmpty a -> HeadsTail a
HeadsTail forall a b. (a -> b) -> a -> b
$ [a
a,a
a]  -- OverloadedLists
  <*> :: forall a b. HeadsTail (a -> b) -> HeadsTail a -> HeadsTail b
(<*>)  = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad HeadsTail where
  HeadsTail NonEmpty a
xs >>= :: forall a b. HeadsTail a -> (a -> HeadsTail b) -> HeadsTail b
>>= a -> HeadsTail b
f = forall a. NonEmpty a -> HeadsTail a
HeadsTail forall a b. (a -> b) -> a -> b
$ forall {l}. IsList l => NonEmpty (NonEmpty (Item l)) -> l
join forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (forall a. HeadsTail a -> NonEmpty a
unHeadsTail forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> HeadsTail b
f) NonEmpty a
xs
   where
    join :: NonEmpty (NonEmpty (Item l)) -> l
join xss :: NonEmpty (NonEmpty (Item l))
xss@(forall a. NonEmpty a -> ([a], a)
splitSnoc -> ([NonEmpty (Item l)]
xss', xs :: NonEmpty (Item l)
xs@(Item l
_:|[Item l]
ys)))
      | forall a. NonEmpty a -> Bool
isSingle NonEmpty (NonEmpty (Item l))
xss Bool -> Bool -> Bool
|| forall a. NonEmpty a -> Bool
isSingle NonEmpty (Item l)
xs
      = [forall a. NonEmpty a -> a
NonEmpty.head forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NonEmpty.head NonEmpty (NonEmpty (Item l))
xss]  -- OverloadedLists 
      | Bool
otherwise
      = forall l. IsList l => [Item l] -> l
fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. NonEmpty a -> a
NonEmpty.head [NonEmpty (Item l)]
xss' forall a. [a] -> [a] -> [a]
++ [Item l]
ys
                                       
instance IsNonEmpty (HeadsTail a) where
  type ItemNE (HeadsTail a) = a
  fromNonEmpty :: NonEmpty (ItemNE (HeadsTail a)) -> HeadsTail a
fromNonEmpty = forall a. NonEmpty a -> HeadsTail a
HeadsTail
  toNonEmpty :: HeadsTail a -> NonEmpty (ItemNE (HeadsTail a))
toNonEmpty = forall a. HeadsTail a -> NonEmpty a
unHeadsTail

instance NonEmptyMonad HeadsTail

instance HeadHeadTail (HeadsTail a) where
  hd' :: HeadsTail a -> HeadsTail a
hd' HeadsTail a
a     = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> HeadsTail a
HeadsTail [HeadsTail a
a]        -- OverloadedLists
  ht :: HeadsTail a -> HeadsTail a -> HeadsTail a
ht  HeadsTail a
a HeadsTail a
b   = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> HeadsTail a
HeadsTail [HeadsTail a
a, HeadsTail a
b]     -- OverloadedLists
  hht :: HeadsTail a -> HeadsTail a -> HeadsTail a -> HeadsTail a
hht HeadsTail a
a HeadsTail a
b HeadsTail a
c = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> HeadsTail a
HeadsTail [HeadsTail a
a, HeadsTail a
b, HeadsTail a
c]  -- OverloadedLists

-- | The 'HeadsTail' monad arises from free head-head-tail algebras,
-- so an interpretation of generators @g@ to a head-head-tail algebra
-- @a@ can be (uniquely) lifted to a homomorphism between
-- head-head-tail algebras.
foldHeadsTail :: (HeadHeadTail a) => (g -> a) -> HeadsTail g -> a
foldHeadsTail :: forall a g. HeadHeadTail a => (g -> a) -> HeadsTail g -> a
foldHeadsTail g -> a
f (HeadsTail (g
x :| []))       = forall a. HeadHeadTail a => a -> a
hd' (g -> a
f g
x)
foldHeadsTail g -> a
f (HeadsTail (g
x :| [Item [g]
y]))      = forall a. HeadHeadTail a => a -> a -> a
ht (g -> a
f g
x) (g -> a
f Item [g]
y)
foldHeadsTail g -> a
f (HeadsTail (g
x :| [Item [g]
y, Item [g]
z]))   = forall a. HeadHeadTail a => a -> a -> a -> a
hht (g -> a
f g
x) (g -> a
f Item [g]
y) (g -> a
f Item [g]
z)
foldHeadsTail g -> a
f (HeadsTail (g
x :| (g
y : [g]
ys))) =
  forall a. HeadHeadTail a => a -> a -> a -> a
hht (g -> a
f g
x) (g -> a
f g
y) (forall a g. HeadHeadTail a => (g -> a) -> HeadsTail g -> a
foldHeadsTail g -> a
f forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> HeadsTail a
HeadsTail forall a b. (a -> b) -> a -> b
$ g
y forall a. a -> [a] -> NonEmpty a
:| [g]
ys)

-- The following two are needed for examples in the docs:

instance IsList (HeadsTail a) where
  type Item (HeadsTail a) = a
  fromList :: [Item (HeadsTail a)] -> HeadsTail a
fromList = forall l. IsNonEmpty l => NonEmpty (ItemNE l) -> l
fromNonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => [Item l] -> l
fromList
  toList :: HeadsTail a -> [Item (HeadsTail a)]
toList = forall l. IsList l => l -> [Item l]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsNonEmpty l => l -> NonEmpty (ItemNE l)
toNonEmpty

instance IsString (HeadsTail Char) where
  fromString :: String -> HeadsTail Char
fromString = forall l. IsList l => [Item l] -> l
fromList

------------------
-- The ΑΩ monad --
------------------

-- | The join of the ΑΩ (Alpha-Omega) monad takes the first element of
-- the first list and the last element of the last list (unless the
-- unit laws require otherwise):
--
-- @
-- join xss | isSingle xss || nonEmptyAll isSingle xss
--          = nonEmptyConcat xss
--          | otherwise
--          =  NonEmpty.head (NonEmpty.head xss)
--          :| NonEmpty.last (NonEmpty.last xss) : []
-- @
--
-- For example:
--
-- >>> toList $ unwrap (join ["John", "Paul", "George", "Ringo"] :: AlphaOmega Char)
-- "Jo"
newtype AlphaOmega a = AlphaOmega { forall a. AlphaOmega a -> NonEmpty a
unAlphaOmega :: NonEmpty a }
 deriving (forall a b. a -> AlphaOmega b -> AlphaOmega a
forall a b. (a -> b) -> AlphaOmega a -> AlphaOmega b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> AlphaOmega b -> AlphaOmega a
$c<$ :: forall a b. a -> AlphaOmega b -> AlphaOmega a
fmap :: forall a b. (a -> b) -> AlphaOmega a -> AlphaOmega b
$cfmap :: forall a b. (a -> b) -> AlphaOmega a -> AlphaOmega b
Functor, Int -> AlphaOmega a -> ShowS
forall a. Show a => Int -> AlphaOmega a -> ShowS
forall a. Show a => [AlphaOmega a] -> ShowS
forall a. Show a => AlphaOmega a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AlphaOmega a] -> ShowS
$cshowList :: forall a. Show a => [AlphaOmega a] -> ShowS
show :: AlphaOmega a -> String
$cshow :: forall a. Show a => AlphaOmega a -> String
showsPrec :: Int -> AlphaOmega a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> AlphaOmega a -> ShowS
Show, AlphaOmega a -> AlphaOmega a -> Bool
forall a. Eq a => AlphaOmega a -> AlphaOmega a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AlphaOmega a -> AlphaOmega a -> Bool
$c/= :: forall a. Eq a => AlphaOmega a -> AlphaOmega a -> Bool
== :: AlphaOmega a -> AlphaOmega a -> Bool
$c== :: forall a. Eq a => AlphaOmega a -> AlphaOmega a -> Bool
Eq)

instance Applicative AlphaOmega where
  pure :: forall a. a -> AlphaOmega a
pure a
a = forall a. NonEmpty a -> AlphaOmega a
AlphaOmega [a
a]                           -- OverloadedLists
  <*> :: forall a b. AlphaOmega (a -> b) -> AlphaOmega a -> AlphaOmega b
(<*>)  = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad AlphaOmega where
  AlphaOmega NonEmpty a
xs >>= :: forall a b. AlphaOmega a -> (a -> AlphaOmega b) -> AlphaOmega b
>>= a -> AlphaOmega b
f = forall a. NonEmpty a -> AlphaOmega a
AlphaOmega forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty (NonEmpty a) -> NonEmpty a
join forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (forall a. AlphaOmega a -> NonEmpty a
unAlphaOmega forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> AlphaOmega b
f) NonEmpty a
xs
   where
    join :: NonEmpty (NonEmpty a) -> NonEmpty a
join NonEmpty (NonEmpty a)
xss | forall a. NonEmpty a -> Bool
isSingle NonEmpty (NonEmpty a)
xss Bool -> Bool -> Bool
|| forall a. (a -> Bool) -> NonEmpty a -> Bool
nonEmptyAll forall a. NonEmpty a -> Bool
isSingle NonEmpty (NonEmpty a)
xss
             = forall a. NonEmpty (NonEmpty a) -> NonEmpty a
nonEmptyConcat NonEmpty (NonEmpty a)
xss
             | Bool
otherwise
             = [ forall a. NonEmpty a -> a
NonEmpty.head (forall a. NonEmpty a -> a
NonEmpty.head NonEmpty (NonEmpty a)
xss)   -- OverloadedLists
               , forall a. NonEmpty a -> a
NonEmpty.last (forall a. NonEmpty a -> a
NonEmpty.last NonEmpty (NonEmpty a)
xss) ]

instance IsNonEmpty (AlphaOmega a) where
  type ItemNE (AlphaOmega a) = a
  fromNonEmpty :: NonEmpty (ItemNE (AlphaOmega a)) -> AlphaOmega a
fromNonEmpty = forall a. NonEmpty a -> AlphaOmega a
AlphaOmega
  toNonEmpty :: AlphaOmega a -> NonEmpty (ItemNE (AlphaOmega a))
toNonEmpty = forall a. AlphaOmega a -> NonEmpty a
unAlphaOmega

instance NonEmptyMonad AlphaOmega

-- The following two are needed for examples in the docs:

instance IsList (AlphaOmega a) where
  type Item (AlphaOmega a) = a
  fromList :: [Item (AlphaOmega a)] -> AlphaOmega a
fromList = forall l. IsNonEmpty l => NonEmpty (ItemNE l) -> l
fromNonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => [Item l] -> l
fromList
  toList :: AlphaOmega a -> [Item (AlphaOmega a)]
toList = forall l. IsList l => l -> [Item l]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsNonEmpty l => l -> NonEmpty (ItemNE l)
toNonEmpty

instance IsString (AlphaOmega Char) where
  fromString :: String -> AlphaOmega Char
fromString = forall l. IsList l => [Item l] -> l
fromList

-------------------------------
-- Dual non-empty list monad --
-------------------------------

liftNEFun :: (NonEmptyMonad m)
          => (NonEmpty a -> NonEmpty a) -> m a -> m a
liftNEFun :: forall (m :: * -> *) a.
NonEmptyMonad m =>
(NonEmpty a -> NonEmpty a) -> m a -> m a
liftNEFun NonEmpty a -> NonEmpty a
f = forall (m :: * -> *) a. NonEmptyMonad m => NonEmpty a -> m a
wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> NonEmpty a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. NonEmptyMonad m => m a -> NonEmpty a
unwrap

-- | Every non-empty list monad has a dual, in which join is defined
-- as
--
-- @
-- reverse . join . reverse . fmap reverse
-- @
--
-- (where join is the join of the original list monad).
--
-- return is the same as in the original monad.
newtype DualNonEmptyMonad m a =
  DualNonEmptyMonad { forall {k} (m :: k -> *) (a :: k). DualNonEmptyMonad m a -> m a
unDualNonEmptyMonad :: m a }
 deriving (forall a b. a -> DualNonEmptyMonad m b -> DualNonEmptyMonad m a
forall a b.
(a -> b) -> DualNonEmptyMonad m a -> DualNonEmptyMonad m b
forall (m :: * -> *) a b.
Functor m =>
a -> DualNonEmptyMonad m b -> DualNonEmptyMonad m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> DualNonEmptyMonad m a -> DualNonEmptyMonad m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> DualNonEmptyMonad m b -> DualNonEmptyMonad m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> DualNonEmptyMonad m b -> DualNonEmptyMonad m a
fmap :: forall a b.
(a -> b) -> DualNonEmptyMonad m a -> DualNonEmptyMonad m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> DualNonEmptyMonad m a -> DualNonEmptyMonad m b
Functor, Int -> DualNonEmptyMonad m a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (m :: k -> *) (a :: k).
Show (m a) =>
Int -> DualNonEmptyMonad m a -> ShowS
forall k (m :: k -> *) (a :: k).
Show (m a) =>
[DualNonEmptyMonad m a] -> ShowS
forall k (m :: k -> *) (a :: k).
Show (m a) =>
DualNonEmptyMonad m a -> String
showList :: [DualNonEmptyMonad m a] -> ShowS
$cshowList :: forall k (m :: k -> *) (a :: k).
Show (m a) =>
[DualNonEmptyMonad m a] -> ShowS
show :: DualNonEmptyMonad m a -> String
$cshow :: forall k (m :: k -> *) (a :: k).
Show (m a) =>
DualNonEmptyMonad m a -> String
showsPrec :: Int -> DualNonEmptyMonad m a -> ShowS
$cshowsPrec :: forall k (m :: k -> *) (a :: k).
Show (m a) =>
Int -> DualNonEmptyMonad m a -> ShowS
Show, DualNonEmptyMonad m a -> DualNonEmptyMonad m a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (m :: k -> *) (a :: k).
Eq (m a) =>
DualNonEmptyMonad m a -> DualNonEmptyMonad m a -> Bool
/= :: DualNonEmptyMonad m a -> DualNonEmptyMonad m a -> Bool
$c/= :: forall k (m :: k -> *) (a :: k).
Eq (m a) =>
DualNonEmptyMonad m a -> DualNonEmptyMonad m a -> Bool
== :: DualNonEmptyMonad m a -> DualNonEmptyMonad m a -> Bool
$c== :: forall k (m :: k -> *) (a :: k).
Eq (m a) =>
DualNonEmptyMonad m a -> DualNonEmptyMonad m a -> Bool
Eq)

instance (NonEmptyMonad m) => Applicative (DualNonEmptyMonad m) where
  pure :: forall a. a -> DualNonEmptyMonad m a
pure = forall {k} (m :: k -> *) (a :: k). m a -> DualNonEmptyMonad m a
DualNonEmptyMonad forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
NonEmptyMonad m =>
(NonEmpty a -> NonEmpty a) -> m a -> m a
liftNEFun forall a. NonEmpty a -> NonEmpty a
NonEmpty.reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  <*> :: forall a b.
DualNonEmptyMonad m (a -> b)
-> DualNonEmptyMonad m a -> DualNonEmptyMonad m b
(<*>)  = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance (NonEmptyMonad m) => Monad (DualNonEmptyMonad m) where
  DualNonEmptyMonad m a
m >>= :: forall a b.
DualNonEmptyMonad m a
-> (a -> DualNonEmptyMonad m b) -> DualNonEmptyMonad m b
>>= a -> DualNonEmptyMonad m b
f = forall {k} (m :: k -> *) (a :: k). m a -> DualNonEmptyMonad m a
DualNonEmptyMonad forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
NonEmptyMonad m =>
(NonEmpty a -> NonEmpty a) -> m a -> m a
liftNEFun forall a. NonEmpty a -> NonEmpty a
NonEmpty.reverse forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
NonEmptyMonad m =>
(NonEmpty a -> NonEmpty a) -> m a -> m a
liftNEFun forall a. NonEmpty a -> NonEmpty a
NonEmpty.reverse m a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      forall (m :: * -> *) a.
NonEmptyMonad m =>
(NonEmpty a -> NonEmpty a) -> m a -> m a
liftNEFun forall a. NonEmpty a -> NonEmpty a
NonEmpty.reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (m :: k -> *) (a :: k). DualNonEmptyMonad m a -> m a
unDualNonEmptyMonad forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DualNonEmptyMonad m b
f

instance (IsNonEmpty (m a)) => IsNonEmpty (DualNonEmptyMonad m a) where
  type ItemNE (DualNonEmptyMonad m a) = ItemNE (m a)
  toNonEmpty :: DualNonEmptyMonad m a -> NonEmpty (ItemNE (DualNonEmptyMonad m a))
toNonEmpty (DualNonEmptyMonad m a
m)    = forall l. IsNonEmpty l => l -> NonEmpty (ItemNE l)
toNonEmpty m a
m
  fromNonEmpty :: NonEmpty (ItemNE (DualNonEmptyMonad m a)) -> DualNonEmptyMonad m a
fromNonEmpty NonEmpty (ItemNE (DualNonEmptyMonad m a))
xs                     = forall {k} (m :: k -> *) (a :: k). m a -> DualNonEmptyMonad m a
DualNonEmptyMonad (forall l. IsNonEmpty l => NonEmpty (ItemNE l) -> l
fromNonEmpty NonEmpty (ItemNE (DualNonEmptyMonad m a))
xs)

instance (NonEmptyMonad m) => NonEmptyMonad (DualNonEmptyMonad m) where
  wrap :: forall a. NonEmpty a -> DualNonEmptyMonad m a
wrap   = forall {k} (m :: k -> *) (a :: k). m a -> DualNonEmptyMonad m a
DualNonEmptyMonad forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. NonEmptyMonad m => NonEmpty a -> m a
wrap
  unwrap :: forall a. DualNonEmptyMonad m a -> NonEmpty a
unwrap = forall (m :: * -> *) a. NonEmptyMonad m => m a -> NonEmpty a
unwrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (m :: k -> *) (a :: k). DualNonEmptyMonad m a -> m a
unDualNonEmptyMonad

---------------------------------------
-- Product of Identity and ListMonad --
---------------------------------------

-- | @'NonEmpty' a@ is isomorphic to the product @(a, [a])@. Thus, we
-- can define a monadic structure on it by a product of the identity
-- monad with any list monad. In particular:
--
-- @
-- return x          = IdXList x (return x)
-- IdXList x m >>= f = IdXList (componentId $ f x) (m >>= componentM . f)
-- @
--
-- where 'return' and '>>=' in definition bodies come from the
-- transformed monad.
data IdXList m a = IdXList { forall (m :: * -> *) a. IdXList m a -> a
componentId :: a, forall (m :: * -> *) a. IdXList m a -> m a
componentM :: m a }
 deriving (forall a b. a -> IdXList m b -> IdXList m a
forall a b. (a -> b) -> IdXList m a -> IdXList m b
forall (m :: * -> *) a b.
Functor m =>
a -> IdXList m b -> IdXList m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> IdXList m a -> IdXList m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> IdXList m b -> IdXList m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> IdXList m b -> IdXList m a
fmap :: forall a b. (a -> b) -> IdXList m a -> IdXList m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> IdXList m a -> IdXList m b
Functor, Int -> IdXList m a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (m :: * -> *) a.
(Show a, Show (m a)) =>
Int -> IdXList m a -> ShowS
forall (m :: * -> *) a.
(Show a, Show (m a)) =>
[IdXList m a] -> ShowS
forall (m :: * -> *) a.
(Show a, Show (m a)) =>
IdXList m a -> String
showList :: [IdXList m a] -> ShowS
$cshowList :: forall (m :: * -> *) a.
(Show a, Show (m a)) =>
[IdXList m a] -> ShowS
show :: IdXList m a -> String
$cshow :: forall (m :: * -> *) a.
(Show a, Show (m a)) =>
IdXList m a -> String
showsPrec :: Int -> IdXList m a -> ShowS
$cshowsPrec :: forall (m :: * -> *) a.
(Show a, Show (m a)) =>
Int -> IdXList m a -> ShowS
Show, IdXList m a -> IdXList m a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (m :: * -> *) a.
(Eq a, Eq (m a)) =>
IdXList m a -> IdXList m a -> Bool
/= :: IdXList m a -> IdXList m a -> Bool
$c/= :: forall (m :: * -> *) a.
(Eq a, Eq (m a)) =>
IdXList m a -> IdXList m a -> Bool
== :: IdXList m a -> IdXList m a -> Bool
$c== :: forall (m :: * -> *) a.
(Eq a, Eq (m a)) =>
IdXList m a -> IdXList m a -> Bool
Eq)

instance (ListMonad m) => Applicative (IdXList m) where
  pure :: forall a. a -> IdXList m a
pure a
x = forall (m :: * -> *) a. a -> m a -> IdXList m a
IdXList a
x (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
  <*> :: forall a b. IdXList m (a -> b) -> IdXList m a -> IdXList m b
(<*>)  = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance (ListMonad m) => Monad (IdXList m) where
  IdXList a
x m a
m >>= :: forall a b. IdXList m a -> (a -> IdXList m b) -> IdXList m b
>>= a -> IdXList m b
f = forall (m :: * -> *) a. a -> m a -> IdXList m a
IdXList (forall (m :: * -> *) a. IdXList m a -> a
componentId forall a b. (a -> b) -> a -> b
$ a -> IdXList m b
f a
x) (m a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. IdXList m a -> m a
componentM forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IdXList m b
f)

instance (ListMonad m) => IsNonEmpty (IdXList m a) where
  type ItemNE (IdXList m a)  = a
  fromNonEmpty :: NonEmpty (ItemNE (IdXList m a)) -> IdXList m a
fromNonEmpty (ItemNE (IdXList m a)
x :| [ItemNE (IdXList m a)]
xs)     = forall (m :: * -> *) a. a -> m a -> IdXList m a
IdXList ItemNE (IdXList m a)
x forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. ListMonad m => [a] -> m a
List.Exotic.wrap [ItemNE (IdXList m a)]
xs
  toNonEmpty :: IdXList m a -> NonEmpty (ItemNE (IdXList m a))
toNonEmpty   (IdXList a
x m a
m) = a
x forall a. a -> [a] -> NonEmpty a
:| forall (m :: * -> *) a. ListMonad m => m a -> [a]
List.Exotic.unwrap m a
m
  
instance (ListMonad m) => NonEmptyMonad (IdXList m)

---------------------------
-- The Short Front monad --
---------------------------

-- | Instances of this class are non-empty list monads for which the
-- 'ShortFront' construction gives a monad.
class (NonEmptyMonad m) => HasShortFront m

instance HasShortFront NonEmpty

-- | (?)
instance HasShortFront Keeper

-- | (?)
instance HasShortFront OpDiscreteHybridNE

-- | (?)
instance HasShortFront MazeWalkNE

-- | (?)
instance (KnownNat n) => HasShortFront (StutterNE n)

-- | (?)
instance HasShortFront AlphaOmega

instance (HasShortRear m) => HasShortFront (DualNonEmptyMonad m)

-- | This is a transformer for a number of monads (instances of the
-- 'HasShortFront' class), whose return is singleton and join takes
-- the prefix of length @p + 2@ of the result of the join of the
-- transformed monad (unless the unit laws require otherwise):
--
-- @
-- joinList xss | 'Control.Monad.List.Exotic.isSingle' xss || all 'Control.Monad.List.Exotic.isSingle' xss = concat xss
--              | otherwise = take (p + 2) (joinList xss)
-- @
--
-- where @joinList@ in the @otherwise@ branch is the @joinList@ of the transformed monad.
--
-- While there are quite a few \"short front\" monads on non-empty
-- lists, only one such monad on possibly-empty lists is known,
-- 'Control.Monad.List.Exotic.StutterKeeper' (the short version is
-- 'Control.Monad.List.Exotic.ShortStutterKeeper').
--
-- For example:
--
-- >>> toList $ unwrap (join ["John", "Paul", "George", "Ringo"] :: ShortFront NonEmpty 4 Char)
-- "JohnPa"
-- >>> toList $ unwrap (join ["John", "Paul", "George", "Ringo"] :: ShortFront MazeWalkNE 4 Char)
-- "Johnho"
-- >>> toList $ unwrap (join ["John", "Paul", "George", "Ringo"] :: ShortFront OpDiscreteHybridNE 4 Char)
-- "JPGRin"
-- >>> toList $ unwrap (join ["John", "Paul", "George", "Ringo"] :: ShortFront Keeper 4 Char)
-- "John"
-- >>> toList $ unwrap (join ["John", "Paul", "George", "Ringo"] :: ShortFront (StutterNE 2) 4 Char)
-- "JJJJ"
-- >>> toList $ unwrap (join ["John", "Paul", "George", "Ringo"] :: ShortFront (StutterNE 6) 4 Char)
-- "JJJJJJ"
newtype ShortFront m (p :: Nat) a = ShortFront { forall {k} (m :: k -> *) (p :: Nat) (a :: k).
ShortFront m p a -> m a
unShortFront :: m a }
 deriving (forall a b. a -> ShortFront m p b -> ShortFront m p a
forall a b. (a -> b) -> ShortFront m p a -> ShortFront m p b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) (p :: Nat) a b.
Functor m =>
a -> ShortFront m p b -> ShortFront m p a
forall (m :: * -> *) (p :: Nat) a b.
Functor m =>
(a -> b) -> ShortFront m p a -> ShortFront m p b
<$ :: forall a b. a -> ShortFront m p b -> ShortFront m p a
$c<$ :: forall (m :: * -> *) (p :: Nat) a b.
Functor m =>
a -> ShortFront m p b -> ShortFront m p a
fmap :: forall a b. (a -> b) -> ShortFront m p a -> ShortFront m p b
$cfmap :: forall (m :: * -> *) (p :: Nat) a b.
Functor m =>
(a -> b) -> ShortFront m p a -> ShortFront m p b
Functor, Int -> ShortFront m p a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (m :: k -> *) (p :: Nat) (a :: k).
Show (m a) =>
Int -> ShortFront m p a -> ShowS
forall k (m :: k -> *) (p :: Nat) (a :: k).
Show (m a) =>
[ShortFront m p a] -> ShowS
forall k (m :: k -> *) (p :: Nat) (a :: k).
Show (m a) =>
ShortFront m p a -> String
showList :: [ShortFront m p a] -> ShowS
$cshowList :: forall k (m :: k -> *) (p :: Nat) (a :: k).
Show (m a) =>
[ShortFront m p a] -> ShowS
show :: ShortFront m p a -> String
$cshow :: forall k (m :: k -> *) (p :: Nat) (a :: k).
Show (m a) =>
ShortFront m p a -> String
showsPrec :: Int -> ShortFront m p a -> ShowS
$cshowsPrec :: forall k (m :: k -> *) (p :: Nat) (a :: k).
Show (m a) =>
Int -> ShortFront m p a -> ShowS
Show, ShortFront m p a -> ShortFront m p a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (m :: k -> *) (p :: Nat) (a :: k).
Eq (m a) =>
ShortFront m p a -> ShortFront m p a -> Bool
/= :: ShortFront m p a -> ShortFront m p a -> Bool
$c/= :: forall k (m :: k -> *) (p :: Nat) (a :: k).
Eq (m a) =>
ShortFront m p a -> ShortFront m p a -> Bool
== :: ShortFront m p a -> ShortFront m p a -> Bool
$c== :: forall k (m :: k -> *) (p :: Nat) (a :: k).
Eq (m a) =>
ShortFront m p a -> ShortFront m p a -> Bool
Eq)

instance (HasShortFront m, KnownNat p) => Applicative (ShortFront m p) where
  pure :: forall a. a -> ShortFront m p a
pure  = forall {k} (m :: k -> *) (p :: Nat) (a :: k).
m a -> ShortFront m p a
ShortFront forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: forall a b.
ShortFront m p (a -> b) -> ShortFront m p a -> ShortFront m p b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance (HasShortFront m, KnownNat p) => Monad (ShortFront m p) where
  ShortFront m a
m >>= :: forall a b.
ShortFront m p a -> (a -> ShortFront m p b) -> ShortFront m p b
>>= a -> ShortFront m p b
f | forall a. NonEmpty a -> Bool
isSingle (forall (m :: * -> *) a. NonEmptyMonad m => m a -> NonEmpty a
unwrap m a
m)
                     Bool -> Bool -> Bool
|| forall a. (a -> Bool) -> NonEmpty a -> Bool
nonEmptyAll forall a. NonEmpty a -> Bool
isSingle
                          (forall (m :: * -> *) a. NonEmptyMonad m => m a -> NonEmpty a
unwrap forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. NonEmptyMonad m => m a -> NonEmpty a
unwrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (m :: k -> *) (p :: Nat) (a :: k).
ShortFront m p a -> m a
unShortFront forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShortFront m p b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
m)
                     = forall {k} (m :: k -> *) (p :: Nat) (a :: k).
m a -> ShortFront m p a
ShortFront forall a b. (a -> b) -> a -> b
$ m a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {k} (m :: k -> *) (p :: Nat) (a :: k).
ShortFront m p a -> m a
unShortFront forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShortFront m p b
f
                     | Bool
otherwise
                     = let p :: Int
p = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy p)
                       in  forall {k} (m :: k -> *) (p :: Nat) (a :: k).
m a -> ShortFront m p a
ShortFront forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
NonEmptyMonad m =>
(NonEmpty a -> NonEmpty a) -> m a -> m a
liftNEFun (forall l. IsList l => [Item l] -> l
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> NonEmpty a -> [a]
NonEmpty.take (Int
p forall a. Num a => a -> a -> a
+ Int
2))
                                      forall a b. (a -> b) -> a -> b
$ m a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {k} (m :: k -> *) (p :: Nat) (a :: k).
ShortFront m p a -> m a
unShortFront forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShortFront m p b
f

instance (IsNonEmpty (m a), KnownNat p) => IsNonEmpty (ShortFront m p a) where
  type ItemNE (ShortFront m p a) = ItemNE (m a)
  toNonEmpty :: ShortFront m p a -> NonEmpty (ItemNE (ShortFront m p a))
toNonEmpty (ShortFront m a
m) = forall l. IsNonEmpty l => l -> NonEmpty (ItemNE l)
toNonEmpty m a
m
  fromNonEmpty :: NonEmpty (ItemNE (ShortFront m p a)) -> ShortFront m p a
fromNonEmpty NonEmpty (ItemNE (ShortFront m p a))
xs = forall {k} (m :: k -> *) (p :: Nat) (a :: k).
m a -> ShortFront m p a
ShortFront (forall l. IsNonEmpty l => NonEmpty (ItemNE l) -> l
fromNonEmpty NonEmpty (ItemNE (ShortFront m p a))
xs)

instance (HasShortFront m, KnownNat p) => NonEmptyMonad (ShortFront m p) where
  wrap :: forall a. NonEmpty a -> ShortFront m p a
wrap   = forall {k} (m :: k -> *) (p :: Nat) (a :: k).
m a -> ShortFront m p a
ShortFront forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. NonEmptyMonad m => NonEmpty a -> m a
wrap
  unwrap :: forall a. ShortFront m p a -> NonEmpty a
unwrap = forall (m :: * -> *) a. NonEmptyMonad m => m a -> NonEmpty a
unwrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (m :: k -> *) (p :: Nat) (a :: k).
ShortFront m p a -> m a
unShortFront

-- The following two are needed for examples in the docs:

instance (HasShortFront m, KnownNat p) => IsList (ShortFront m p a) where
  type Item (ShortFront m p a) = a
  fromList :: [Item (ShortFront m p a)] -> ShortFront m p a
fromList = forall (m :: * -> *) a. NonEmptyMonad m => NonEmpty a -> m a
wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => [Item l] -> l
fromList
  toList :: ShortFront m p a -> [Item (ShortFront m p a)]
toList = forall l. IsList l => l -> [Item l]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. NonEmptyMonad m => m a -> NonEmpty a
unwrap

instance (HasShortFront m, KnownNat p) => IsString (ShortFront m p Char) where
  fromString :: String -> ShortFront m p Char
fromString = forall l. IsList l => [Item l] -> l
fromList

---------------------------
-- The Short Rear monad --
---------------------------

-- | Instances of this class are non-empty list monads for which the
-- 'ShortRear' construction gives a monad.
class (NonEmptyMonad m) => HasShortRear m

instance HasShortRear NonEmpty

-- | (?)
instance HasShortRear DiscreteHybridNE

-- | (?)
instance HasShortRear AlphaOmega

instance (HasShortFront m) => HasShortRear (DualNonEmptyMonad m)

-- | Similar to 'ShortFront', but gives a monad if restricted to a
-- suffix of the length @p + 2@.
--
-- For example:
--
-- >>> toList $ unwrap (join ["John", "Paul", "George", "Ringo"] :: ShortRear NonEmpty 5 Char)
-- "geRingo"
-- >>> toList $ unwrap (join ["John", "Paul", "George", "Ringo"] :: ShortRear DiscreteHybridNE 5 Char)
-- "leRingo"
--
newtype ShortRear m (p :: Nat) a = ShortRear { forall {k} (m :: k -> *) (p :: Nat) (a :: k).
ShortRear m p a -> m a
unShortRear :: m a }
 deriving (forall a b. a -> ShortRear m p b -> ShortRear m p a
forall a b. (a -> b) -> ShortRear m p a -> ShortRear m p b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) (p :: Nat) a b.
Functor m =>
a -> ShortRear m p b -> ShortRear m p a
forall (m :: * -> *) (p :: Nat) a b.
Functor m =>
(a -> b) -> ShortRear m p a -> ShortRear m p b
<$ :: forall a b. a -> ShortRear m p b -> ShortRear m p a
$c<$ :: forall (m :: * -> *) (p :: Nat) a b.
Functor m =>
a -> ShortRear m p b -> ShortRear m p a
fmap :: forall a b. (a -> b) -> ShortRear m p a -> ShortRear m p b
$cfmap :: forall (m :: * -> *) (p :: Nat) a b.
Functor m =>
(a -> b) -> ShortRear m p a -> ShortRear m p b
Functor, Int -> ShortRear m p a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (m :: k -> *) (p :: Nat) (a :: k).
Show (m a) =>
Int -> ShortRear m p a -> ShowS
forall k (m :: k -> *) (p :: Nat) (a :: k).
Show (m a) =>
[ShortRear m p a] -> ShowS
forall k (m :: k -> *) (p :: Nat) (a :: k).
Show (m a) =>
ShortRear m p a -> String
showList :: [ShortRear m p a] -> ShowS
$cshowList :: forall k (m :: k -> *) (p :: Nat) (a :: k).
Show (m a) =>
[ShortRear m p a] -> ShowS
show :: ShortRear m p a -> String
$cshow :: forall k (m :: k -> *) (p :: Nat) (a :: k).
Show (m a) =>
ShortRear m p a -> String
showsPrec :: Int -> ShortRear m p a -> ShowS
$cshowsPrec :: forall k (m :: k -> *) (p :: Nat) (a :: k).
Show (m a) =>
Int -> ShortRear m p a -> ShowS
Show, ShortRear m p a -> ShortRear m p a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (m :: k -> *) (p :: Nat) (a :: k).
Eq (m a) =>
ShortRear m p a -> ShortRear m p a -> Bool
/= :: ShortRear m p a -> ShortRear m p a -> Bool
$c/= :: forall k (m :: k -> *) (p :: Nat) (a :: k).
Eq (m a) =>
ShortRear m p a -> ShortRear m p a -> Bool
== :: ShortRear m p a -> ShortRear m p a -> Bool
$c== :: forall k (m :: k -> *) (p :: Nat) (a :: k).
Eq (m a) =>
ShortRear m p a -> ShortRear m p a -> Bool
Eq)

instance (HasShortRear m, KnownNat p) => Applicative (ShortRear m p) where
  pure :: forall a. a -> ShortRear m p a
pure  = forall {k} (m :: k -> *) (p :: Nat) (a :: k).
m a -> ShortRear m p a
ShortRear forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  <*> :: forall a b.
ShortRear m p (a -> b) -> ShortRear m p a -> ShortRear m p b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

nonEmptyTakeRear :: Int -> NonEmpty a -> [a]
nonEmptyTakeRear :: forall a. Int -> NonEmpty a -> [a]
nonEmptyTakeRear Int
p = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> NonEmpty a -> [a]
NonEmpty.take Int
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> NonEmpty a
NonEmpty.reverse

instance (HasShortRear m, KnownNat p) => Monad (ShortRear m p) where
  ShortRear m a
m >>= :: forall a b.
ShortRear m p a -> (a -> ShortRear m p b) -> ShortRear m p b
>>= a -> ShortRear m p b
f | forall a. NonEmpty a -> Bool
isSingle (forall (m :: * -> *) a. NonEmptyMonad m => m a -> NonEmpty a
unwrap m a
m)
                    Bool -> Bool -> Bool
|| forall a. (a -> Bool) -> NonEmpty a -> Bool
nonEmptyAll forall a. NonEmpty a -> Bool
isSingle
                         (forall (m :: * -> *) a. NonEmptyMonad m => m a -> NonEmpty a
unwrap forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. NonEmptyMonad m => m a -> NonEmpty a
unwrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (m :: k -> *) (p :: Nat) (a :: k).
ShortRear m p a -> m a
unShortRear forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShortRear m p b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
m)
                    = forall {k} (m :: k -> *) (p :: Nat) (a :: k).
m a -> ShortRear m p a
ShortRear forall a b. (a -> b) -> a -> b
$ m a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {k} (m :: k -> *) (p :: Nat) (a :: k).
ShortRear m p a -> m a
unShortRear forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShortRear m p b
f
                    | Bool
otherwise
                    = let p :: Int
p = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy p)
                      in  forall {k} (m :: k -> *) (p :: Nat) (a :: k).
m a -> ShortRear m p a
ShortRear forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
NonEmptyMonad m =>
(NonEmpty a -> NonEmpty a) -> m a -> m a
liftNEFun (forall l. IsList l => [Item l] -> l
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> NonEmpty a -> [a]
nonEmptyTakeRear (Int
p forall a. Num a => a -> a -> a
+ Int
2))
                                    forall a b. (a -> b) -> a -> b
$ m a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {k} (m :: k -> *) (p :: Nat) (a :: k).
ShortRear m p a -> m a
unShortRear forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShortRear m p b
f

instance (IsNonEmpty (m a), KnownNat p) => IsNonEmpty (ShortRear m p a) where
  type ItemNE (ShortRear m p a) = ItemNE (m a)
  toNonEmpty :: ShortRear m p a -> NonEmpty (ItemNE (ShortRear m p a))
toNonEmpty (ShortRear m a
m) = forall l. IsNonEmpty l => l -> NonEmpty (ItemNE l)
toNonEmpty m a
m
  fromNonEmpty :: NonEmpty (ItemNE (ShortRear m p a)) -> ShortRear m p a
fromNonEmpty NonEmpty (ItemNE (ShortRear m p a))
xs = forall {k} (m :: k -> *) (p :: Nat) (a :: k).
m a -> ShortRear m p a
ShortRear (forall l. IsNonEmpty l => NonEmpty (ItemNE l) -> l
fromNonEmpty NonEmpty (ItemNE (ShortRear m p a))
xs)

instance (HasShortRear m, KnownNat p) => NonEmptyMonad (ShortRear m p) where
  wrap :: forall a. NonEmpty a -> ShortRear m p a
wrap   = forall {k} (m :: k -> *) (p :: Nat) (a :: k).
m a -> ShortRear m p a
ShortRear forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. NonEmptyMonad m => NonEmpty a -> m a
wrap
  unwrap :: forall a. ShortRear m p a -> NonEmpty a
unwrap = forall (m :: * -> *) a. NonEmptyMonad m => m a -> NonEmpty a
unwrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (m :: k -> *) (p :: Nat) (a :: k).
ShortRear m p a -> m a
unShortRear

-- The following two are needed for examples in the docs:

instance (HasShortRear m, KnownNat p) => IsList (ShortRear m p a) where
  type Item (ShortRear m p a) = a
  fromList :: [Item (ShortRear m p a)] -> ShortRear m p a
fromList = forall (m :: * -> *) a. NonEmptyMonad m => NonEmpty a -> m a
wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => [Item l] -> l
fromList
  toList :: ShortRear m p a -> [Item (ShortRear m p a)]
toList = forall l. IsList l => l -> [Item l]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. NonEmptyMonad m => m a -> NonEmpty a
unwrap

instance (HasShortRear m, KnownNat p) => IsString (ShortRear m p Char) where
  fromString :: String -> ShortRear m p Char
fromString = forall l. IsList l => [Item l] -> l
fromList