{-# Language
 DefaultSignatures
,PatternSynonyms
,ViewPatterns
,MultiParamTypeClasses
,RankNTypes
,ScopedTypeVariables
,TypeApplications
,FunctionalDependencies
#-}

module FIFO_r where

import Control.Applicative (liftA2)
import Data.Maybe (fromJust)
import Data.Functor.Apply (Apply(..),liftF2)
import Empty
import State

----
-- Stream_r

class Get_r r f | f -> r  where
 get_r :: f a -> (r a,f a)

class Set_r r f | f -> r  where
 set_r :: (r a,f a) -> f a

class (Get_r r f,Set_r r f) => Stream_r r f | f -> r

-- (:::) reserved for the version with r = Identity to help abstract away these Identity wrappers
pattern  (::::) :: Stream_r r f => r a -> f a -> f a
pattern x :::: xs <- (get_r -> (x,xs))
 where  x :::: xs =   set_r    (x,xs)

stream_rDifference :: (Get_r r t, Set_r r' t', Apply f) => (r a -> f (r' b)) -> State (t a) (f ((t' b) -> t' b))
stream_rDifference f xs = (\(x,xs')->(fmap (curry set_r) (f x),xs')) (get_r xs)

convertStream_r :: (Get_r r t, Set_r r' t', Apply f) => (r a -> f (r' b)) -> t a -> f (t' b)
convertStream_r f = hyloState (stream_rDifference f) g
 where
  g :: Apply f => CoState (f (t' b)) (f ((t' b) -> t' b))
  g (h,xs) = liftF2 (\f x ->f (x)) h xs


----
-- Linear_r

class (Get_r r f) => GetS_r r f | f -> r where
 isLast_r :: f a -> Bool
 isLast_r = null . snd . getS_r
 getS_r :: f a -> (r a,Maybe (f a))
 getS_r xs | isLast_r @r xs = fmap (const Nothing) $ get_r xs
           | otherwise    = fmap Just            $ get_r xs
 {-# MINIMAL isLast_r | getS_r #-}

get_rDefault :: GetS_r r f => f a -> (r a,f a)
get_rDefault  x = (\(x',xs) -> (x',maybe (error "get_r default via getS_r given \"last\"") id xs)) (getS_r x)

class (Set_r r f) => SetS_r r f | f -> r  where
 create_r :: r a -> f a
 create_r r = setS_r (r,Nothing)
 setS_r :: (r a,Maybe (f a)) -> f a
 setS_r (r,Just xs) = set_r (r,xs)
 {-# MINIMAL create_r | setS_r #-}

set_rDefault  :: SetS_r r f => (r a,f a) -> f a
set_rDefault = setS_r . fmap Just

class (Stream_r r f,GetS_r r f,SetS_r r f) => Linear_r r f | f -> r

pattern Last_r :: Linear_r r f => r a -> f a
pattern Last_r x   <- (getS_r -> (x, Nothing))
 where  Last_r x =     setS_r    (x,Nothing)

linear_rDifference :: (GetS_r r t, SetS_r r' t', Apply f) => (r a -> f (r' b)) -> SafeState (t a) (f (Maybe (t' b) -> t' b))
linear_rDifference f xs = (\(x,xs')->(fmap (curry setS_r) (f x),xs')) (getS_r xs)

convert1_r :: (GetS_r r t, SetS_r r' t', Apply f) => (r a -> f (r' b)) -> t a -> f (t' b)
convert1_r f = hyloSafeState (linear_rDifference f) g
 where
  g :: Apply f => CoSafeState (f (t' b)) (f (Maybe (t' b) -> t' b))
  g (h,Nothing) = fmap (\h' -> h' Nothing) h
  g (h,Just xs) = liftF2 (\f x ->f (Just x)) h xs -- is this lifting of Just slow?

----
-- Stack_r

class (GetS_r r f,Empty f) => Uncons_r r f | f -> r  where
 uncons_r :: f a -> Maybe (r a,f a)
 default uncons_r :: f a -> Maybe (r a,f a)
 uncons_r Empty = Nothing
 uncons_r xs = Just $ fmap (maybe empty id) $ getS_r xs

isLast_rDefault :: Uncons_r r f => f a -> Bool
isLast_rDefault = isEmpty . snd . get_r

getS_rDefault :: Stack_r r f => f a -> (r a,Maybe (f a))
getS_rDefault Empty = error "getS_r Empty"
getS_rDefault xs    = fmap Just $ fromJust $ uncons_r xs

class (SetS_r r f,Empty f) => Cons_r r f | f -> r  where
 cons_r   :: Maybe (r a,f a) -> f a
 default cons_r :: Maybe (r a,f a) -> f a
 cons_r Nothing = empty
 cons_r (Just (x,xs)) = set_r (x,xs)

emptyDefault :: Cons_r r f => f a
emptyDefault = cons_r Nothing

setS_rDefault :: Stack_r r f => (r a,Maybe (f a)) -> f a
setS_rDefault = cons_r . Just . fmap (maybe empty id)

class (Empty f,Linear_r r f,Uncons_r r f,Cons_r r f) => Stack_r r f | f -> r  where

stack_rDifference :: (Uncons_r r t, Cons_r r' t', Applicative f) => (r a -> f (r' b)) -> StateSafe (t a) (f ((t' b) -> t' b))
stack_rDifference f xs = fmap (\(x,xs')->(fmap (curry (cons_r .Just) ) (f x),xs')) (uncons_r xs)

convert_r :: (Uncons_r r t, Cons_r r' t', Applicative f) => (r a -> f (r' b)) -> t a -> f (t' b)
convert_r f = hyloStateSafe (stack_rDifference f) g
 where
  g :: (Empty t',Applicative f) => CoStateSafe (f (t' b)) (f ((t' b) -> t' b))
  g Nothing = pure empty
  g (Just (h,xs)) = liftA2 (\f x ->f (x)) h xs