{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}

module Data.List.NonNonEmpty where

import Control.Lens
    ( Each, Reversing(..), Lens' )
import Data.Data ( Data )
import Data.List.NonEmpty ( NonEmpty((:|)) )
import qualified Data.List.NonEmpty as NonEmpty
import Data.Functor ( Functor(fmap), (<$>) )
import Data.Functor.Apply ( Apply((<.>)) )
import Data.Functor.Bind ( Bind((>>-)) )
import Data.Functor.Classes
    ( Eq1(..), Ord1(..), Show1(liftShowsPrec) )
import Data.Semigroup.Foldable ( Foldable1(foldMap1, toNonEmpty) )
import Data.Semigroup.Traversable ( Traversable1(traverse1) )
import GHC.Generics ( Generic, Generic1 )

data NonNonEmpty a =
  NonNonEmpty a (NonEmpty a)
  deriving (Eq, Ord, Show)

deriving instance Data a => Data (NonNonEmpty a)
deriving instance Generic (NonNonEmpty a)
deriving instance Generic1 NonNonEmpty

instance Eq1 NonNonEmpty where
  liftEq eq (NonNonEmpty h1 t1) (NonNonEmpty h2 t2) =
    eq h1 h2 && liftEq eq t1 t2

instance Ord1 NonNonEmpty where
  liftCompare cmp (NonNonEmpty h1 t1) (NonNonEmpty h2 t2) =
    cmp h1 h2 <> liftCompare cmp t1 t2

instance Show1 NonNonEmpty where
  liftShowsPrec shwP shwL p (NonNonEmpty h t) =
    showString "NonNonEmpty " . shwP 6 h . liftShowsPrec shwP shwL p t

instance Semigroup (NonNonEmpty a) where
  NonNonEmpty h1 t1 <> NonNonEmpty h2 t2 =
     NonNonEmpty h1 (t1 <> NonEmpty.cons h2 t2)

instance Functor NonNonEmpty where
  fmap f (NonNonEmpty h t) =
    NonNonEmpty (f h) (fmap f t)

instance Foldable NonNonEmpty where
  foldMap f (NonNonEmpty h t) =
    f h <> foldMap f t

instance Foldable1 NonNonEmpty where
  foldMap1 f (NonNonEmpty h ts) =
    f h <> foldMap1 f ts

instance Traversable NonNonEmpty where
  traverse f (NonNonEmpty h t) =
    NonNonEmpty <$> f h <*> traverse f t

instance Traversable1 NonNonEmpty where
  traverse1 f (NonNonEmpty h t) =
    NonNonEmpty <$> f h <.> traverse1 f t

instance Apply NonNonEmpty where
  (<.>) =
    (<*>)

instance Applicative NonNonEmpty where
  NonNonEmpty hf tf <*> NonNonEmpty hx tx =
    NonNonEmpty (hf hx) (tf <*> tx)
  pure =
    return

instance Bind NonNonEmpty where
  (>>-) =
    (>>=)

instance Monad NonNonEmpty where
  NonNonEmpty h t >>= f =
    f h <> foldMap1 f t
  return a =
    NonNonEmpty a (return a)

head ::
  Lens'
    (NonNonEmpty a)
    a
head f (NonNonEmpty h t) =
  fmap (\h' -> NonNonEmpty h' t) (f h)

tail ::
  Lens'
    (NonNonEmpty a)
    (NonEmpty a)
tail f (NonNonEmpty h t) =
  fmap (NonNonEmpty h) (f t)

head2 ::
  Lens'
    (NonNonEmpty a)
    (a, a)
head2 f (NonNonEmpty h1 (h2 :| t)) =
  fmap (\(h1', h2') -> NonNonEmpty h1' (h2' :| t)) (f (h1, h2))

tail2 ::
  Lens'
    (NonNonEmpty a)
    [a]
tail2 f (NonNonEmpty h1 (h2 :| t)) =
  fmap (\t' -> NonNonEmpty h1 (h2 :| t')) (f t)

instance Reversing (NonNonEmpty a) where
  reversing x =
    let h1 :| (h2 : tt) = NonEmpty.reverse (toNonEmpty x)
    in  NonNonEmpty h1 (h2 :| tt)

instance Each (NonNonEmpty a) (NonNonEmpty b) a b where