module Jungle
( Jungle
, Tree
, Node
, Path
, createJungle
, createTree
, getTreeByName
, getRootNode
, updateRootNode
, addNewChildAt
, deleteChildAt
, putAttribute
, deleteAttribute
, getAttributes
, drawNode -- デバッグ用
) where

import qualified Data.Map as M
import qualified Data.ByteString.Lazy.Char8 as B
import Control.Concurrent.STM
import Data.Maybe (fromJust)

data Jungle = Jungle { getJungleMap :: (M.Map String Tree) } 

data Tree = Tree
          { rootNode :: (TVar Node)
          , treeName :: String
          }

data Node = Node
          { children   :: Children
          , attributes :: Attributes
          } deriving (Show)

-- Mapのkeyやvalueの型は固定しているが、
-- jungle作成時、もしくは木作成時に与えるように変更することも容易
newtype Children   = Children   { getChildrenMap :: (M.Map Int Node) } deriving (Show)
newtype Attributes = Attributes { getAttributesMap :: (M.Map String B.ByteString) } deriving (Show)

type Path = [Int]
type Position = Int

createJungle :: Jungle
createJungle = Jungle M.empty

-- 同じ名前のTreeが存在する場合、上書きする
-- Eitherなどで失敗させるほうがいいかもしれない
createTree :: Jungle -> String -> IO Jungle
createTree (Jungle map) tree_name = atomically $ do
    tree <- emptyTree tree_name
    return (Jungle (M.insert tree_name tree map))

emptyTree :: String -> STM Tree
emptyTree tree_name = do
    node <- newTVar emptyNode
    return (Tree node tree_name)

emptyNode :: Node
emptyNode = Node (Children M.empty) (Attributes M.empty)

getTreeByName :: Jungle -> String -> Maybe Tree
getTreeByName (Jungle map) tree_name = M.lookup tree_name map

updateTree :: Jungle -> Tree -> Jungle
updateTree jungle tree = Jungle (M.insert tree_name tree map)
  where
    map = getJungleMap jungle
    tree_name = treeName tree 

getRootNode :: Tree -> IO Node
getRootNode tree = atomically $ readTVar (rootNode tree)

-- ルートノードを更新する
updateRootNode :: Tree -> Node -> IO ()
updateRootNode tree node = atomically $ writeTVar (rootNode tree) node

-- 新しい木構造を作成し、最新のルートノードとなるNodeを返す
-- Pathの位置にNodeが存在しない場合どうするか？
addNewChildAt :: Node -> Path -> Position -> Node
addNewChildAt parent []     pos = addChild parent pos emptyNode
addNewChildAt parent (x:xs) pos = addChild parent x $ addNewChildAt x_node xs pos
  where
    map = getChildrenMap $ children parent
    x_node = case M.lookup x map of
               Just x -> x

-- 子を追加したNodeを新しく作成して返す
-- 同じ位置に既に子がある場合は？
-- 現在はinsertでそのまま上書き
addChild :: Node -> Position -> Node -> Node
addChild node pos child = Node new_child attr
  where
    map = getChildrenMap $ children node
    new_child = Children (M.insert pos child map)
    attr = attributes node

-- 子を削除した新しいNodeを追加するのに等しい
-- addNewChildAtのコピペ、一般化して関数に抽出したい
-- Nodeを操作してNodeを返す関数を渡せばいけそう
deleteChildAt :: Node -> Path -> Position -> Node
deleteChildAt parent []     pos = deleteChild parent pos
deleteChildAt parent (x:xs) pos = addChild parent x $ deleteChildAt x_node xs pos
  where
    map = getChildrenMap $ children parent
    x_node = case M.lookup x map of
               Just x -> x

deleteChild :: Node -> Position -> Node
deleteChild node pos = Node new_child attr
  where
    map = getChildrenMap $ children node
    new_child = Children (M.delete pos map)
    attr = attributes node

-- attribute関連はaddNewChildAtを利用する
-- 現在はコピペ、関数に抽出したい
putAttribute :: Node -> Path -> String -> B.ByteString -> Node
putAttribute parent []     key value = putAttr parent key value
putAttribute parent (x:xs) key value = addChild parent x $ putAttribute x_node xs key value
  where
    map = getChildrenMap $ children parent
    x_node = case M.lookup x map of
               Just x -> x

putAttr :: Node -> String -> B.ByteString -> Node
putAttr node key value = Node child attr
  where
    map = getAttributesMap $ attributes node
    attr = Attributes (M.insert key value map)
    child = children node

deleteAttribute :: Node -> Path -> String -> Node
deleteAttribute parent []     key = deleteAttr parent key
deleteAttribute parent (x:xs) key = addChild parent x $ deleteAttribute x_node xs key
  where
    map = getChildrenMap $ children parent
    x_node = case M.lookup x map of
               Just x -> x
    
deleteAttr :: Node -> String -> Node
deleteAttr node key = Node child attr
  where
    map = getAttributesMap $ attributes node
    attr = Attributes (M.delete key map)
    child = children node

-- データを取り出す関連の関数
-- getNodeとgetchild, getattributeなど？

getNode :: Node -> Path -> Node
getNode node []     = node
getNode node (x:xs) = getNode child xs
  where
    map = getChildrenMap $ children node
    child = case M.lookup x map of
              Just x -> x

getAttributes :: Node -> Path -> String -> Maybe B.ByteString
getAttributes node path key = M.lookup key map
  where
    target = getNode node path
    map = getAttributesMap $ attributes target

-- デバッグ用表示関数
drawNode :: Node -> String
drawNode node = unlines $ draw "root" node

draw string node = string : drawSubTrees keys
  where
    map = getChildrenMap $ children node
    keys = M.keys map
    drawSubTrees [] = []
    drawSubTrees [t] = 
      "|" : shift "`-" " " (draw (show t) (fromJust $ M.lookup t map))
    drawSubTrees (t:ts) =
      "|" : shift "+- " "|  " (draw (show t) (fromJust $ M.lookup t map )) ++ drawSubTrees ts
    shift first other = zipWith (++) (first : repeat other)