{-# LANGUAGE TypeFamilies, InstanceSigs #-}
{- | now we want to generalize and unify interface to zipper, we would like to
   have constructor class CZipper which would be parametrized by container c
   (of kind * -> *) and the class would define:
  
   * zipper type for container c of values a: Zipper c a
   * toZipper, fromZipper and modify functions

   The latter can be expressed in Haskell2010, however, we need extension to
   type system for the first one: TypeFamilies let us define data types inside
   type/constructor classes (we define kind of data type in class definition
   and implement it in each instance).
-}
module Zips where

import Data.Maybe

class CZipper c where
    -- this is new: we define that instance must containt type Zipper of
    -- kind (* -> *) -> * -> *
    -- family keyword is optional
    data family Zipper c :: * -> *

    -- those are normat constructor-class functions (much like fmap in Functor)
    toZipper :: c a -> Zipper c a
    fromZipper :: Zipper c a -> c a
    modify :: (a -> a) -> Zipper c a -> Zipper c a

instance CZipper [] where
    -- in instance we need to define implementation of data type, much like
    -- normal data definition
    data Zipper [] a = LZip { backward :: [a], forward :: [a] }
                       deriving ( Eq, Show, Read )

    -- and also functions
    toZipper :: [a] -> Zipper [] a
    toZipper = LZip []

    fromZipper :: Zipper [] a -> [a]
    fromZipper (LZip [] xs) = xs
    fromZipper (LZip (b:bs) xs) = fromZipper $ LZip bs (b:xs)

    modify :: (a -> a) -> Zipper [] a -> Zipper [] a
    modify f z@(LZip bs []) = z
    modify f (LZip bs (x:xs)) = LZip bs (f x : xs)

goForward :: Zipper [] a -> Maybe (Zipper [] a)
goForward (LZip bs []) = Nothing
goForward (LZip bs (x:xs)) = Just $ LZip (x:bs) xs

goBackward :: Zipper [] a -> Maybe (Zipper [] a)
goBackward (LZip [] xs) = Nothing
goBackward (LZip (b:bs) xs) = Just $ LZip bs (b:xs)

data BinTree a = BNode (BinTree a) a (BinTree a)
               | BEmpty
               deriving ( Eq, Show, Read )

data TreeDir a = TLeft a (BinTree a)
               | TRight (BinTree a) a
               deriving ( Eq, Show, Read )

instance CZipper BinTree where
    data Zipper BinTree a = TZip [TreeDir a] (BinTree a)
                          deriving ( Eq, Show, Read )

    toZipper :: BinTree a -> Zipper BinTree a
    toZipper tree = TZip [] tree

    fromZipper :: Zipper BinTree a -> BinTree a
    fromZipper (TZip [] tree) = tree
    fromZipper tree = fromZipper . fromJust $ goUp tree

    modify :: (a -> a) -> Zipper BinTree a -> Zipper BinTree a
    modify f z@(TZip ds BEmpty) = z
    modify f (TZip ds (BNode l v r)) = TZip ds (BNode l (f v) r)

goLeft :: Zipper BinTree a -> Maybe (Zipper BinTree a)
goLeft (TZip ds BEmpty) = Nothing
goLeft (TZip ds (BNode l v r)) = Just $ TZip (TLeft v r : ds) l

goRight :: Zipper BinTree a -> Maybe (Zipper BinTree a)
goRight (TZip ds BEmpty) = Nothing
goRight (TZip ds (BNode l v r)) = Just $ TZip (TRight l v : ds) r

goUp :: Zipper BinTree a -> Maybe (Zipper BinTree a)
goUp (TZip [] _) = Nothing
goUp (TZip (TLeft v r : ds) tree) = Just $ TZip ds (BNode tree v r)
goUp (TZip (TRight l v : ds) tree) = Just $ TZip ds (BNode l v tree)

testTree :: BinTree Int
testTree = BNode (BNode (BNode BEmpty 4 BEmpty)
                        2
                        (BNode BEmpty 5 BEmpty))
                 1
                 (BNode (BNode BEmpty 6 BEmpty)
                        3
                        (BNode BEmpty 7 BEmpty))