import Control.Applicative
import Data.Hashable
import Data.Maybe

-- 二分木. Applicative functor.
data BinaryTree a = Node a (BinaryTree a) (BinaryTree a) | Empty
  deriving (Show, Functor)

btValue :: BinaryTree a -> Maybe a
btValue Empty        = Nothing
btValue (Node a _ _) = Just a

instance Applicative BinaryTree where
  pure a = Node a Empty Empty
  Empty <*> _ = Empty
  Node f s t <*> Node a s' t' = Node (f a) (s <*> s') (t <*> t')

instance Alternative BinaryTree where
  empty = Empty
  Empty <|> a = a
  a <|> _ = a

type Hash = Int

-- 任意のデータを適当な長さに分割したものを, ハッシュ木（マークル木）に変換する
toHashTree :: Hashable h => (Hash -> Hash -> Hash) -> [h] -> BinaryTree Hash
toHashTree composeHash list =
  let hashed = fmap hash list :: [Hash]
      leaves = fmap (pure :: Hash -> BinaryTree Hash) hashed
   in foldHashTrees composeHash leaves

-- 2つのハッシュ木のルートノードを返す
-- ルートノードのハッシュ値は、子ノードのハッシュ値を合成してハッシュを計算したもの
rootHashTree :: HashComposer -> BinaryTree Hash -> BinaryTree Hash -> BinaryTree Hash
rootHashTree f s t =
  let s' = btValue s
      t' = btValue t
   in maybe Empty (\a -> a `seq` Node a s t) $
    (f <$> s' <*> t') <|> (hash <$> s') <|> (hash <$> t')

-- rootHashTreeを ルート木が一つになるまで再帰的に適用する. 概ね foldl
foldHashTrees :: HashComposer -> [BinaryTree Hash] -> BinaryTree Hash
foldHashTrees f xs =
  case rootHashTrees f xs of
    []     -> Empty
    (x:[]) -> x
    list   -> foldHashTrees f list
  where
  -- rootHashTree を二分木のリストに対して適用する. 概ね fmap
  rootHashTrees :: HashComposer -> [BinaryTree Hash] -> [BinaryTree Hash]
  rootHashTrees _ [] = []
  rootHashTrees _ (x:[]) = [x]  -- ここ親ノードを追加した方がいいのかも
  rootHashTrees f (x:x':xs) = rootHashTree f x x' : rootHashTrees f xs  

-- Hash composers
type HashComposer = Hash -> Hash -> Hash
catHash, addHash :: HashComposer
catHash h k = hash $ show h <> show k
addHash h k = hash $ h + k

-- 適当なデータ
someData, someData' :: String
someData = "Hello World"
someData' = "Hell, World"

main :: IO ()
main = do
  -- The root hash is Just (-253164247939317930)
  let hashTree = toHashTree catHash someData
  -- The root hash is Just 5222981838165211227
  let hashTree' = toHashTree catHash someData'
  putStrLn $ "The root hash is " <> show (btValue hashTree)
  putStrLn $ "The root hash is " <> show (btValue hashTree')