{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Stack.UniqueOrdered where

import Data.Foldable (Foldable (foldl))
import Data.Traversable (Traversable ())
import Data.Monoid (Monoid (mempty, mappend))
import Control.Monad (Monad ((>>=), return))
import Control.Applicative (Applicative (), pure, (<*>))
import Prelude (flip, ($), tail, (.), Eq ((==)), Show (), Ord ((>),(<)), Functor (), fmap)

class (Foldable stack) =>UOStack (stack :: * -> *) where
  -- | Sorted insert
  insert ::(Ord a, Eq a) =>a ->stack a ->stack a
  insert = flip into
  into ::(Ord a, Eq a) =>stack a ->a ->stack a
  into = flip insert
  -- | Pop the head off
  pop ::(Ord a, Eq a) =>stack a ->stack a
  -- | Add list of items
  inserts ::(Ord a, Eq a) =>[a] ->stack a ->stack a
  inserts = flip intos
  intos ::(Ord a, Eq a) =>stack a ->[a] ->stack a
  intos = foldl into
  -- | As the name suggests
  merge ::(Ord a, Eq a) =>stack a ->stack a ->stack a
  merge = foldl into



-- | The head is the smallest
newtype Asc a = Asc {unAsc ::[a]}
  deriving (Show, Eq, Functor, Foldable, Traversable)
instance Monad Asc where
  return = Asc . return
  (Asc xs) >>= f = Asc $ xs >>= (unAsc . f)
instance (Ord a) =>Monoid (Asc a) where
  mempty = Asc []
  (Asc xs) `mappend` (Asc ys) = intos (Asc []) $ xs `mappend` ys

-- | The head is the largest
newtype Des a = Des {unDes ::[a]}
  deriving (Show, Eq, Functor, Foldable, Traversable)
instance Monad Des where
  return = Des . return
  (Des xs) >>= f = Des $ xs >>= (unDes . f)
instance (Ord a) =>Monoid (Des a) where
  mempty = Des []
  (Des xs) `mappend` (Des ys) = intos (Des []) $ xs `mappend` ys

instance UOStack Asc where
  insert a (Asc [])         = Asc [a]
  insert a (Asc xss@(x:xs)) | a < x = Asc (a:xss)
                            | a ==x = Asc xss
                            | a > x = Asc $ x : (unAsc $ insert a $ Asc xs)
  pop (Asc xs) = Asc (tail xs)

instance UOStack Des where
  insert a (Des [])         = Des [a]
  insert a (Des xss@(x:xs)) | a > x = Des (a:xss)
                            | a ==x = Des xss
                            | a < x = Des $ x : (unDes $ insert a $ Des xs)
  pop (Des xs) = Des (tail xs)