{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}

module Data.Tape where

import Data.Onion
import Data.Positive

import Control.Comonad
import Control.Lens
import qualified Data.Foldable as Foldable (toList, fold)
import Data.Maybe
import GHC.Exts

class Comonad f =>
      Tape f where
  moveLeft :: f a -> Maybe (f a)
  moveRight :: f a -> Maybe (f a)
  tapeFocus :: Lens' (f a) a

movedLeft
  :: Tape f
  => Traversal' (f a) (f a)
movedLeft func t =
  case moveLeft t of
    Nothing -> pure t
    Just x -> fromMaybe t . moveRight <$> func x

movedRight
  :: Tape f
  => Traversal' (f a) (f a)
movedRight func t =
  case moveRight t of
    Nothing -> pure t
    Just x -> fromMaybe t . moveLeft <$> func x

data StreamTape a =
  StreamTape [a]
             a
             [a]
  deriving (Eq, Show, Functor, Traversable, Foldable)

instance FunctorWithIndex Int StreamTape where
  imap func (StreamTape l c r) =
    StreamTape
      (zipWith func [-1,-2 ..] l)
      (func 0 c)
      (zipWith func [1 ..] r)

instance FoldableWithIndex Int StreamTape where
  ifoldMap func = Foldable.fold . imap func

instance TraversableWithIndex Int StreamTape where
  itraverse func = sequenceA . imap func

streamTapeFromList :: [a] -> StreamTape a
streamTapeFromList [] = error "Cannot make empty stream tape"
streamTapeFromList [x] = StreamTape [] x []
streamTapeFromList [x, y] = StreamTape [] x [y]
streamTapeFromList xs =
  (\(StreamTape l c r) ->
     StreamTape (l ++ [head xs]) c (r ++ [last xs])) $
  streamTapeFromList (tail $ init xs)

instance IsList (StreamTape a) where
  type Item (StreamTape a) = a
  fromList = streamTapeFromList
  toList = Foldable.toList

instance Applicative StreamTape where
  pure a = StreamTape (repeat a) a (repeat a)
  StreamTape rf cf lf <*> StreamTape ra ca la =
    StreamTape (zipWith ($) rf ra) (cf ca) (zipWith ($) lf la)

instance Comonad StreamTape where
  extract (StreamTape _ a _) = a
  duplicate t =
    StreamTape
      (tail $
       catMaybes $
       takeWhile isJust $ iterate (>>= moveLeft) (Just t))
      t
      (tail $
       catMaybes $
       takeWhile isJust $ iterate (>>= moveRight) (Just t))

instance Tape StreamTape where
  moveLeft (StreamTape (l:ls) c rs) =
    Just $ StreamTape ls l (c : rs)
  moveLeft (StreamTape [] _ _) = Nothing
  moveRight (StreamTape ls c (r:rs)) =
    Just $ StreamTape (c : ls) r rs
  moveRight (StreamTape _ _ []) = Nothing
  tapeFocus f (StreamTape r c l) =
    (\c' -> StreamTape r c' l) <$> f c
