Optional.hs

module Data.Optional (
   T(Nil, Cons),
   (?:),
   fromEmpty,
   fromNonEmpty,
   ) where

import qualified Data.NonEmpty.Class as C
import qualified Data.NonEmpty as NonEmpty
import qualified Data.Empty as Empty
import Data.NonEmptyPrivate (Aux(Aux), snoc)

import qualified Data.Traversable as Trav
import qualified Data.Foldable as Fold
import Control.Applicative (pure, liftA2, )

import qualified Test.QuickCheck as QC

import Control.Monad (return, )
import Data.Functor (Functor, fmap, )
import Data.Function (($), (.), )
import Data.Ord (Ord, Ordering(GT), (>), )
import Data.Tuple.HT (mapSnd, )
import qualified Prelude as P
import Prelude (Eq, Show, Num, uncurry, )


data T f a = Nil | Cons a (f a)
   deriving (Eq, Ord)

fromEmpty :: Empty.T a -> T f a
fromEmpty Empty.Cons = Nil

fromNonEmpty :: NonEmpty.T f a -> T f a
fromNonEmpty (NonEmpty.Cons x xs) = Cons x xs


instance (C.Show f, P.Show a) => P.Show (T f a) where
   showsPrec = C.showsPrec

instance (C.Show f) => C.Show (T f) where
   showsPrec _ Nil = P.showString "Nil"
   showsPrec p (Cons x xs) =
      P.showParen (p>5) $
      P.showsPrec 6 x . P.showString "?:" . C.showsPrec 5 xs


infixr 5 ?:

(?:) :: a -> f a -> T f a
(?:) = Cons


instance P.Functor f => P.Functor (T f) where
   fmap _ Nil = Nil
   fmap f (Cons x xs) = Cons (f x) (fmap f xs)

instance (Fold.Foldable f) => Fold.Foldable (T f) where
   foldr _ y Nil = y
   foldr f y (Cons x xs) = f x (Fold.foldr f y xs)

instance (Trav.Traversable f) => Trav.Traversable (T f) where
   sequenceA Nil = pure Nil
   sequenceA (Cons x xs) = liftA2 Cons x (Trav.sequenceA xs)

instance (C.Arbitrary f, QC.Arbitrary a) => QC.Arbitrary (T f a) where
   arbitrary =
      QC.oneof
         [return Nil, liftA2 Cons QC.arbitrary C.arbitrary]
   shrink Nil = []
   shrink (Cons x xs) =
      P.map (\(y, Aux ys) -> Cons y ys) (QC.shrink (x, Aux xs))

instance C.Empty (T f) where
   empty = Nil

instance (C.Cons f, C.Empty f) => C.Cons (T f) where
   cons x Nil = Cons x C.empty
   cons x0 (Cons x1 xs) = Cons x0 $ C.cons x1 xs

instance (C.Repeat f) => C.Repeat (T f) where
   repeat x = Cons x $ C.repeat x

instance C.Zip f => C.Zip (T f) where
   zipWith f (Cons x xs) (Cons y ys) = Cons (f x y) (C.zipWith f xs ys)
   zipWith _ _ _ = Nil

instance (Trav.Traversable f, C.Reverse f) => C.Reverse (T f) where
   reverse Nil = Nil
   reverse (Cons x xs) =
      fromNonEmpty (snoc (C.reverse xs) x)

instance (NonEmpty.Insert f, C.Sort f) => C.Sort (T f) where
   sort Nil = Nil
   sort (Cons x xs) =
      fromNonEmpty $ NonEmpty.insert x $ C.sort xs

instance (NonEmpty.InsertBy f, C.SortBy f) => C.SortBy (T f) where
   sortBy _ Nil = Nil
   sortBy f (Cons x xs) =
      fromNonEmpty $ NonEmpty.insertBy f x $ C.sortBy f xs

instance (NonEmpty.Insert f) => NonEmpty.Insert (T f) where
   insert y xt =
      uncurry NonEmpty.Cons $
      case xt of
         Nil -> (y, xt)
         Cons x xs ->
            case P.compare y x of
               GT -> (x, fromNonEmpty $ NonEmpty.insert y xs)
               _ -> (y, xt)

instance (NonEmpty.InsertBy f) => NonEmpty.InsertBy (T f) where
   insertBy f y xt =
      uncurry NonEmpty.Cons $
      case xt of
         Nil -> (y, xt)
         Cons x xs ->
            case f y x of
               GT -> (x, fromNonEmpty $ NonEmpty.insertBy f y xs)
               _ -> (y, xt)

instance NonEmpty.RemoveEach f => NonEmpty.RemoveEach (T f) where
   removeEach (NonEmpty.Cons x Nil) = NonEmpty.Cons (x, Nil) Nil
   removeEach (NonEmpty.Cons x0 xs0@(Cons x1 xs1)) =
      NonEmpty.Cons (x0, xs0) $
      fmap (mapSnd (x0 ?:)) $
      fromNonEmpty $ NonEmpty.removeEach $ NonEmpty.Cons x1 xs1

instance NonEmpty.Tails f => NonEmpty.Tails (T f) where
   tails xt =
      NonEmpty.force $
      case xt of
         Nil -> NonEmpty.Cons C.empty Nil
         Cons x xs ->
            case NonEmpty.tails xs of
               xss -> NonEmpty.Cons (C.cons x $ NonEmpty.head xss) (fromNonEmpty xss)