{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
{-# OPTIONS -fno-warn-orphans #-}

-- ------------------------------------------------------------

{- |
   Module     : Data.Tree.NTree.Zipper.TypeDefs
   Copyright  : Copyright (C) 2010 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
   Stability  : stable
   Portability: portable

   Implementation of navigateble trees for
   rose trees. The implementation is done with zippers.
   A description and introductory tutorial about zippers
   can be found in <http://learnyouahaskell.com/zippers>
-}

-- ------------------------------------------------------------

module Data.Tree.NTree.Zipper.TypeDefs
{-
    ( NTZipper
    , NTree
    , toNTZipper
    , fromNTZipper
    )
-}
where

import Data.Tree.Class

import Data.Tree.NavigatableTree.Class
import Data.Tree.NavigatableTree.XPathAxis      ( childAxis )

import Data.Tree.NTree.TypeDefs

-- ------------------------------------------------------------

-- | Zipper for rose trees
--
-- A zipper consist of the current tree and the branches on the way back to the root

data NTZipper a         = NTZ
                          { forall a. NTZipper a -> NTree a
ntree   :: (NTree a)
                          , forall a. NTZipper a -> NTBreadCrumbs a
context :: (NTBreadCrumbs a)
                          }
                          deriving (Int -> NTZipper a -> ShowS
forall a. Show a => Int -> NTZipper a -> ShowS
forall a. Show a => [NTZipper a] -> ShowS
forall a. Show a => NTZipper a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NTZipper a] -> ShowS
$cshowList :: forall a. Show a => [NTZipper a] -> ShowS
show :: NTZipper a -> String
$cshow :: forall a. Show a => NTZipper a -> String
showsPrec :: Int -> NTZipper a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> NTZipper a -> ShowS
Show)

-- | The list of unzipped nodes from a current tree back to the root

type NTBreadCrumbs a    = [NTCrumb a]

-- | One unzipped step consists of the left siblings, the node info and the right siblings

data NTCrumb a          = NTC
                          (NTrees a)            -- left side
                          a                     -- node
                          (NTrees a)            -- right side
                          deriving (Int -> NTCrumb a -> ShowS
forall a. Show a => Int -> NTCrumb a -> ShowS
forall a. Show a => [NTCrumb a] -> ShowS
forall a. Show a => NTCrumb a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NTCrumb a] -> ShowS
$cshowList :: forall a. Show a => [NTCrumb a] -> ShowS
show :: NTCrumb a -> String
$cshow :: forall a. Show a => NTCrumb a -> String
showsPrec :: Int -> NTCrumb a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> NTCrumb a -> ShowS
Show)

-- ------------------------------------------------------------

-- | Conversion of a rose tree into a navigatable rose tree

toNTZipper              :: NTree a -> NTZipper a
toNTZipper :: forall a. NTree a -> NTZipper a
toNTZipper NTree a
t            = forall a. NTree a -> NTBreadCrumbs a -> NTZipper a
NTZ NTree a
t []

{-# INLINE toNTZipper #-}

-- | Conversion of a navigatable rose tree into an ordinary rose tree.
--
-- The context, the parts for moving up to the root are just removed from the tree.
-- So when transforming a navigatable tree by moving around and by changing some nodes,
-- one has to navigate back
-- to the root, else that parts are removed from the result

fromNTZipper            :: NTZipper a -> NTree a
fromNTZipper :: forall a. NTZipper a -> NTree a
fromNTZipper            = forall a. NTZipper a -> NTree a
ntree

{-# INLINE fromNTZipper #-}

-- ------------------------------------------------------------

up                      :: NTZipper a -> Maybe (NTZipper a)
up :: forall a. NTZipper a -> Maybe (NTZipper a)
up NTZipper a
z
    | forall a. NTZipper a -> Bool
isTop NTZipper a
z           = forall a. Maybe a
Nothing
    | Bool
otherwise         = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. NTree a -> NTBreadCrumbs a -> NTZipper a
NTZ (forall a. NTree a -> NTCrumb a -> NTree a
up1 NTree a
t NTCrumb a
bc) [NTCrumb a]
bcs
    where
    NTZ NTree a
t (NTCrumb a
bc : [NTCrumb a]
bcs)    = NTZipper a
z

{-# INLINE up #-}

down                    :: NTZipper a -> Maybe (NTZipper a)
down :: forall a. NTZipper a -> Maybe (NTZipper a)
down (NTZ (NTree a
n NTrees a
cs) NTBreadCrumbs a
bcs)
          | forall (t :: * -> *) a. Foldable t => t a -> Bool
null NTrees a
cs     = forall a. Maybe a
Nothing
          | Bool
otherwise   = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. NTree a -> NTBreadCrumbs a -> NTZipper a
NTZ (forall a. [a] -> a
head NTrees a
cs) (forall a. NTrees a -> a -> NTrees a -> NTCrumb a
NTC [] a
n (forall a. [a] -> [a]
tail NTrees a
cs) forall a. a -> [a] -> [a]
: NTBreadCrumbs a
bcs)

{-# INLINE down #-}

toTheRight                   :: NTZipper a -> Maybe (NTZipper a)
toTheRight :: forall a. NTZipper a -> Maybe (NTZipper a)
toTheRight NTZipper a
z
    | forall a. NTZipper a -> Bool
isTop NTZipper a
z
      Bool -> Bool -> Bool
||
      forall (t :: * -> *) a. Foldable t => t a -> Bool
null NTrees a
rs           = forall a. Maybe a
Nothing
    | Bool
otherwise         = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. NTree a -> NTBreadCrumbs a -> NTZipper a
NTZ NTree a
t' (NTCrumb a
bc' forall a. a -> [a] -> [a]
: [NTCrumb a]
bcs)
    where
    (NTZ NTree a
t (NTCrumb a
bc : [NTCrumb a]
bcs))  = NTZipper a
z
    (NTC NTrees a
ls a
n NTrees a
rs)       = NTCrumb a
bc
    t' :: NTree a
t'                  = forall a. [a] -> a
head NTrees a
rs
    bc' :: NTCrumb a
bc'                 = forall a. NTrees a -> a -> NTrees a -> NTCrumb a
NTC (NTree a
t forall a. a -> [a] -> [a]
: NTrees a
ls) a
n (forall a. [a] -> [a]
tail NTrees a
rs)

{-# INLINE toTheRight #-}

toTheLeft                    :: NTZipper a -> Maybe (NTZipper a)
toTheLeft :: forall a. NTZipper a -> Maybe (NTZipper a)
toTheLeft NTZipper a
z
    | forall a. NTZipper a -> Bool
isTop NTZipper a
z
      Bool -> Bool -> Bool
||
      forall (t :: * -> *) a. Foldable t => t a -> Bool
null NTrees a
ls           = forall a. Maybe a
Nothing
    | Bool
otherwise         = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. NTree a -> NTBreadCrumbs a -> NTZipper a
NTZ NTree a
t' (NTCrumb a
bc' forall a. a -> [a] -> [a]
: [NTCrumb a]
bcs)
    where
    (NTZ NTree a
t (NTCrumb a
bc : [NTCrumb a]
bcs))  = NTZipper a
z
    (NTC NTrees a
ls a
n NTrees a
rs)       = NTCrumb a
bc
    t' :: NTree a
t'                  = forall a. [a] -> a
head NTrees a
ls
    bc' :: NTCrumb a
bc'                 = forall a. NTrees a -> a -> NTrees a -> NTCrumb a
NTC (forall a. [a] -> [a]
tail NTrees a
ls) a
n (NTree a
t forall a. a -> [a] -> [a]
: NTrees a
rs)

{-# INLINE toTheLeft #-}

addToTheLeft            :: NTree a -> NTZipper a -> Maybe (NTZipper a)
addToTheLeft :: forall a. NTree a -> NTZipper a -> Maybe (NTZipper a)
addToTheLeft NTree a
t NTZipper a
z
    | forall a. NTZipper a -> Bool
isTop NTZipper a
z           = forall a. Maybe a
Nothing
    | Bool
otherwise         = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. NTree a -> NTBreadCrumbs a -> NTZipper a
NTZ NTree a
t' (forall a. NTrees a -> a -> NTrees a -> NTCrumb a
NTC (NTree a
tforall a. a -> [a] -> [a]
:[NTree a]
ls) a
n [NTree a]
rs forall a. a -> [a] -> [a]
: [NTCrumb a]
bcs)
    where
    (NTZ NTree a
t' (NTCrumb a
bc : [NTCrumb a]
bcs)) = NTZipper a
z
    (NTC [NTree a]
ls a
n [NTree a]
rs)       = NTCrumb a
bc
{-# INLINE addToTheLeft #-}

addToTheRight            :: NTree a -> NTZipper a -> Maybe (NTZipper a)
addToTheRight :: forall a. NTree a -> NTZipper a -> Maybe (NTZipper a)
addToTheRight NTree a
t NTZipper a
z
    | forall a. NTZipper a -> Bool
isTop NTZipper a
z           = forall a. Maybe a
Nothing
    | Bool
otherwise         = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. NTree a -> NTBreadCrumbs a -> NTZipper a
NTZ NTree a
t' (forall a. NTrees a -> a -> NTrees a -> NTCrumb a
NTC NTrees a
ls a
n (NTree a
tforall a. a -> [a] -> [a]
:NTrees a
rs) forall a. a -> [a] -> [a]
: [NTCrumb a]
bcs)
    where
    (NTZ NTree a
t' (NTCrumb a
bc : [NTCrumb a]
bcs)) = NTZipper a
z
    (NTC NTrees a
ls a
n NTrees a
rs)       = NTCrumb a
bc
{-# INLINE addToTheRight #-}

dropFromTheLeft            :: NTZipper a -> Maybe (NTZipper a)
dropFromTheLeft :: forall a. NTZipper a -> Maybe (NTZipper a)
dropFromTheLeft NTZipper a
z
    | forall a. NTZipper a -> Bool
isTop NTZipper a
z           = forall a. Maybe a
Nothing
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null NTrees a
ls           = forall a. Maybe a
Nothing
    | Bool
otherwise         = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. NTree a -> NTBreadCrumbs a -> NTZipper a
NTZ NTree a
t' (forall a. NTrees a -> a -> NTrees a -> NTCrumb a
NTC (forall a. [a] -> [a]
tail NTrees a
ls) a
n NTrees a
rs forall a. a -> [a] -> [a]
: [NTCrumb a]
bcs)
    where
    (NTZ NTree a
t' (NTCrumb a
bc : [NTCrumb a]
bcs)) = NTZipper a
z
    (NTC NTrees a
ls a
n NTrees a
rs)       = NTCrumb a
bc
{-# INLINE dropFromTheLeft #-}

dropFromTheRight        :: NTZipper a -> Maybe (NTZipper a)
dropFromTheRight :: forall a. NTZipper a -> Maybe (NTZipper a)
dropFromTheRight NTZipper a
z
    | forall a. NTZipper a -> Bool
isTop NTZipper a
z           = forall a. Maybe a
Nothing
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null NTrees a
rs           = forall a. Maybe a
Nothing
    | Bool
otherwise         = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. NTree a -> NTBreadCrumbs a -> NTZipper a
NTZ NTree a
t' (forall a. NTrees a -> a -> NTrees a -> NTCrumb a
NTC NTrees a
ls a
n (forall a. [a] -> [a]
tail NTrees a
rs) forall a. a -> [a] -> [a]
: [NTCrumb a]
bcs)
    where
    (NTZ NTree a
t' (NTCrumb a
bc : [NTCrumb a]
bcs)) = NTZipper a
z
    (NTC NTrees a
ls a
n NTrees a
rs)       = NTCrumb a
bc
{-# INLINE dropFromTheRight #-}

-- ------------------------------------------------------------

isTop                   :: NTZipper a -> Bool
isTop :: forall a. NTZipper a -> Bool
isTop                   = forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NTZipper a -> NTBreadCrumbs a
context

{-# INLINE isTop #-}

up1                     :: NTree a -> NTCrumb a -> NTree a
up1 :: forall a. NTree a -> NTCrumb a -> NTree a
up1 NTree a
t (NTC NTrees a
ls a
n NTrees a
rs)     = forall a. a -> NTrees a -> NTree a
NTree a
n (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) (NTree a
t forall a. a -> [a] -> [a]
: NTrees a
rs) NTrees a
ls)

{-# INLINE up1 #-}

-- ------------------------------------------------------------

instance Functor NTZipper where
    fmap :: forall a b. (a -> b) -> NTZipper a -> NTZipper b
fmap a -> b
f (NTZ NTree a
t NTBreadCrumbs a
xs)   = forall a. NTree a -> NTBreadCrumbs a -> NTZipper a
NTZ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f NTree a
t) (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) NTBreadCrumbs a
xs)
    {-# INLINE fmap #-}

instance Functor NTCrumb where
    fmap :: forall a b. (a -> b) -> NTCrumb a -> NTCrumb b
fmap a -> b
f (NTC NTrees a
xs a
x NTrees a
ys)= forall a. NTrees a -> a -> NTrees a -> NTCrumb a
NTC (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) NTrees a
xs) (a -> b
f a
x) (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) NTrees a
ys)
    {-# INLINE fmap #-}

instance Tree NTZipper where
    mkTree :: forall a. a -> [NTZipper a] -> NTZipper a
mkTree a
n [NTZipper a]
cl         = forall a. NTree a -> NTZipper a
toNTZipper forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Tree t => a -> [t a] -> t a
mkTree a
n forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. NTZipper a -> NTree a
ntree [NTZipper a]
cl

    getNode :: forall a. NTZipper a -> a
getNode             = forall (t :: * -> *) a. Tree t => t a -> a
getNode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NTZipper a -> NTree a
ntree
    {-# INLINE getNode #-}
    getChildren :: forall a. NTZipper a -> [NTZipper a]
getChildren         = forall (t :: * -> *) a. NavigatableTree t => t a -> [t a]
childAxis
    {-# INLINE getChildren #-}

    changeNode :: forall a. (a -> a) -> NTZipper a -> NTZipper a
changeNode     a -> a
cf NTZipper a
t = NTZipper a
t { ntree :: NTree a
ntree = forall (t :: * -> *) a. Tree t => (a -> a) -> t a -> t a
changeNode a -> a
cf (forall a. NTZipper a -> NTree a
ntree NTZipper a
t) }
    changeChildren :: forall a.
([NTZipper a] -> [NTZipper a]) -> NTZipper a -> NTZipper a
changeChildren [NTZipper a] -> [NTZipper a]
cf NTZipper a
t = NTZipper a
t { ntree :: NTree a
ntree = forall (t :: * -> *) a. Tree t => [t a] -> t a -> t a
setChildren (forall a b. (a -> b) -> [a] -> [b]
map forall a. NTZipper a -> NTree a
ntree forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NTZipper a] -> [NTZipper a]
cf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. NavigatableTree t => t a -> [t a]
childAxis forall a b. (a -> b) -> a -> b
$ NTZipper a
t) (forall a. NTZipper a -> NTree a
ntree NTZipper a
t) }

    foldTree :: forall a b. (a -> [b] -> b) -> NTZipper a -> b
foldTree a -> [b] -> b
f          = forall (t :: * -> *) a b. Tree t => (a -> [b] -> b) -> t a -> b
foldTree a -> [b] -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NTZipper a -> NTree a
ntree
    {-# INLINE foldTree #-}

instance NavigatableTree NTZipper where
    mvDown :: forall a. NTZipper a -> Maybe (NTZipper a)
mvDown              = forall a. NTZipper a -> Maybe (NTZipper a)
down
    {-# INLINE mvDown #-}

    mvUp :: forall a. NTZipper a -> Maybe (NTZipper a)
mvUp                = forall a. NTZipper a -> Maybe (NTZipper a)
up
    {-# INLINE mvUp #-}

    mvLeft :: forall a. NTZipper a -> Maybe (NTZipper a)
mvLeft              = forall a. NTZipper a -> Maybe (NTZipper a)
toTheLeft
    {-# INLINE mvLeft #-}

    mvRight :: forall a. NTZipper a -> Maybe (NTZipper a)
mvRight             = forall a. NTZipper a -> Maybe (NTZipper a)
toTheRight
    {-# INLINE mvRight #-}

instance NavigatableTreeToTree NTZipper NTree where
    fromTree :: forall a. NTree a -> NTZipper a
fromTree            = forall a. NTree a -> NTZipper a
toNTZipper
    {-# INLINE fromTree #-}

    toTree :: forall a. NTZipper a -> NTree a
toTree              = forall a. NTZipper a -> NTree a
fromNTZipper
    {-# INLINE toTree #-}

instance NavigatableTreeModify NTZipper NTree where
    addTreeLeft :: forall a. NTree a -> NTZipper a -> Maybe (NTZipper a)
addTreeLeft         = forall a. NTree a -> NTZipper a -> Maybe (NTZipper a)
addToTheLeft
    {-# INLINE addTreeLeft #-}

    addTreeRight :: forall a. NTree a -> NTZipper a -> Maybe (NTZipper a)
addTreeRight        = forall a. NTree a -> NTZipper a -> Maybe (NTZipper a)
addToTheRight
    {-# INLINE addTreeRight #-}

    dropTreeLeft :: forall a. NTZipper a -> Maybe (NTZipper a)
dropTreeLeft        = forall a. NTZipper a -> Maybe (NTZipper a)
dropFromTheLeft
    {-# INLINE dropTreeLeft #-}

    dropTreeRight :: forall a. NTZipper a -> Maybe (NTZipper a)
dropTreeRight       = forall a. NTZipper a -> Maybe (NTZipper a)
dropFromTheRight
    {-# INLINE dropTreeRight #-}

    substThisTree :: forall a. NTree a -> NTZipper a -> NTZipper a
substThisTree NTree a
t NTZipper a
nt  = NTZipper a
nt { ntree :: NTree a
ntree = NTree a
t }
    {-# INLINE substThisTree #-}

-- ------------------------------------------------------------