<commit_before>-- "src/Dao/Tree.hs"  provides a fundamental data type used in the Dao
-- System, the "Tree", which is similar to the "Data.Map" data type.
-- 
-- Copyright (C) 2008-2013  <NAME>.
-- This file is part of the Dao System.
--
-- The Dao System is free software: you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
-- 
-- The Dao System is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program (see the file called "LICENSE"). If not, see
-- <http://www.gnu.org/licenses/agpl.html>.


{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Dao.Tree where

import           Control.Applicative
import           Control.Monad
import           Control.Monad.Identity
import           Control.Monad.Trans
import           Control.Monad.State

import           Data.Typeable
import           Data.Monoid
import           Data.List (intercalate)
-- import           Data.Binary
import qualified Data.Map as M
import           Data.Word

import Debug.Trace

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

data Tree p n
  = Void
  | Leaf   { branchData :: n }
  | Branch { branchMap  :: M.Map p (Tree p n) }
  | LeafBranch 
    { branchData :: n
    , branchMap  :: M.Map p (Tree p n)
    }
  deriving Typeable
instance (Show p, Show n) => Show (Tree p n) where
  show o = case o of
    Void           -> "voidTree"
    Leaf       o   -> "(leaf "++show o++")"
    Branch       t -> "(branch ["++branch t++"])"
    LeafBranch o t -> "(leaf "++show o++" branch ["++branch t++"])"
    where { branch t = intercalate ", " (M.assocs t  >>= \ (nm, o) -> [show nm++"="++show o]) }
instance (Eq p, Eq n) => Eq (Tree p n) where
  (==) a b = case (a, b) of
    (Void           , Void           ) -> True
    (Leaf       a   , Leaf       b   ) -> a == b
    (Branch     a   , Branch     b   ) -> a == b
    (LeafBranch a aa, LeafBranch b bb) -> a == b && aa == bb
    _                                  -> False
instance (Ord p, Ord n) => Ord (Tree p n) where
  compare a b = case (a, b) of
    (Void           , Void           ) -> EQ
    (Leaf       a   , Leaf       b   ) -> compare a  b
    (Branch       aa, Branch       bb) -> compare aa bb
    (LeafBranch a aa, LeafBranch b bb) -> case compare a b of
      EQ -> compare aa bb
      e  -> e
    (Void           , _              ) -> LT
    (_              , Void           ) -> GT
    (Leaf       _   , _              ) -> LT
    (_              , Leaf       _   ) -> GT
    (Branch       _ , _              ) -> LT
    (_              , Branch       _ ) -> GT
instance Ord p => Functor (Tree p) where
  fmap f tree = case tree of
    Void           -> Void
    Leaf       a   -> Leaf (f a)
    Branch       m -> Branch (fmap (fmap f) m)
    LeafBranch a m -> LeafBranch (f a) (fmap (fmap f) m)
instance (Ord p, Monoid n) => Monoid (Tree p n) where
  mempty  = Void
  mappend = unionWith mappend

-- | A combinator to modify the data in the 'Leaf' and 'LeafBranch' nodes of a tree when passed to
-- one of the functions below.
type ModLeaf     n = Maybe n -> Maybe n

-- | A combinator to modify the data in the 'Branch' and 'LeafBranch' nodes of a tree when passed to
-- one of the functions below.
type ModBranch p n = Maybe (M.Map p (Tree p n)) -> Maybe (M.Map p (Tree p n))

-- | If a 'Tree' is 'Void' or a contains a branch that is equivalent to 'Data.Map.empty',
-- 'Data.Maybe.Nothing' is returned.
notVoid :: Tree p n -> Maybe (Tree p n)
notVoid t = case t of
  Void                      -> Nothing
  Branch       b | M.null b -> Nothing
  LeafBranch a b | M.null b -> Just (Leaf a)
  _                         -> Just t

-- | If the given node is a 'Leaf' or 'LeafBranch', returns the Leaf portion of the node.
getLeaf :: Tree p n -> Maybe n
getLeaf t = case t of { Leaf n -> Just n; LeafBranch n _ -> Just n; _ -> Nothing }

-- | If the given node is a 'Branch' or 'LeafBranch', returns the branch portion of the node.
getBranch :: Tree p a -> Maybe (M.Map p (Tree p a))
getBranch t = case t of { Branch b -> Just b; LeafBranch _ b -> Just b; _ -> Nothing }

-- | Use a 'ModLeaf' function to insert, update, or remove 'Leaf' and 'LeafBranch' nodes.
alterLeaf :: ModLeaf n -> Tree p n -> Tree p n
alterLeaf alt t = maybe Void id $ case t of
  Void           -> alt Nothing         >>= \o -> Just (Leaf o)
  Leaf       o   -> alt (Just o)        >>= \o -> Just (Leaf o)
  Branch       b -> mplus (alt Nothing  >>= \o -> Just (LeafBranch o b)) (Just (Branch b))
  LeafBranch o b -> mplus (alt (Just o) >>= \o -> Just (LeafBranch o b)) (Just (Branch b))

alterBranch :: (Eq p, Ord p) => ModBranch p n -> Tree p n -> Tree p n
alterBranch alt t = maybe Void id $ case t of
  Void           -> alt Nothing         >>= \b -> Just (Branch b)
  Leaf       o   -> mplus (alt Nothing  >>= \b -> Just (LeafBranch o b)) (Just (Leaf o))
  Branch       b -> alt (Just b)        >>= \b -> Just (Branch b)
  LeafBranch o b -> mplus (alt (Just b) >>= \b -> Just (LeafBranch o b)) (Just (Leaf o))

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

data ZipTree p n = ZipTree{ focus :: Tree p n, history :: [(p, Tree p n)] }

newtype UpdateTreeT p n m a = UpdateTreeT{ getUpdateTreeStateT :: StateT (ZipTree p n) m a }
type UpdateTree p n a = UpdateTreeT p n Identity a

instance Monad m =>
  Monad (UpdateTreeT p n m) where
    return = UpdateTreeT . return
    (UpdateTreeT a) >>= b = UpdateTreeT (a >>= getUpdateTreeStateT . b)
instance Functor m =>
  Functor (UpdateTreeT p n m) where { fmap f (UpdateTreeT m) = UpdateTreeT (fmap f m); }
instance (Monad m, Functor m) =>
  Applicative (UpdateTreeT p n m) where { pure = return; (<*>) = ap; }
instance Monad m =>
  MonadState (ZipTree p n) (UpdateTreeT p n m) where { state = UpdateTreeT . state; }
instance MonadTrans (UpdateTreeT p n) where { lift m = UpdateTreeT (lift m); }

-- | Like 'Control.Monad.State.runState', evaluates an 'UpdateTree' monad transformer lifting the
-- 'Control.Monad.Identity.Identity' monad, removing the identity monad after evaluation to give you
-- a pure function.
runUpdateTree :: Ord p => UpdateTree p n a -> Tree p n -> (a, Tree p n)
runUpdateTree updfn = runIdentity . runUpdateTreeT updfn

-- | Like 'Control.Monad.State.execState', disgards the value returned to the 'UpdateTree' monad and
-- only returns the 'Tree'.
execUpdateTree :: Ord p => UpdateTree p n a -> Tree p n -> Tree p n
execUpdateTree updfn = snd . runUpdateTree updfn

-- | Update a 'Tree' using an 'UpdateTreeT' monad, much like how 'Control.Monad.State.runStateT'
-- works. Evaluates to a monadic computation of the lifted type @m@ that 'Control.Monad.return's a
-- pair containing the value last 'Control.Monad.return'ed to the lifted monad and the updated
-- 'Tree'.
runUpdateTreeT :: (Ord p, Functor m, Monad m) => UpdateTreeT p n m a -> Tree p n -> m (a, Tree p n)
runUpdateTreeT updfn tree = fmap (fmap focus) $
  runStateT (getUpdateTreeStateT (updfn >>= \a -> home >> return a)) (ZipTree{focus=tree, history=[]})

-- | Go to the node with the given path. If the path does not exist, it is created.
goto :: (Ord p, Monad m) => [p] -> UpdateTreeT p n m (Tree p n)
goto path = case path of
  []       -> gets focus
  (p:path) -> do
    st <- get
    let step tree = put $ st{focus=Void, history=(p, focus st):history st}
    case getBranch (focus st) >>= M.lookup p of
      Nothing   -> step Void
      Just tree -> step tree
    goto path

-- | Go up one level in the tree, storing the current sub-tree into the upper tree, unless the<commit_msg>Found a very subtle bug which was effecting how tree objects were being constructed. I don't know how I could have introduced this bug (it was probably a type-o) or how it has gone so long without being caught. But running some more tests, it seems the change I have made is a correction.<commit_after>-- "src/Dao/Tree.hs"  provides a fundamental data type used in the Dao
-- System, the "Tree", which is similar to the "Data.Map" data type.
-- 
-- Copyright (C) 2008-2013  <NAME>.
-- This file is part of the Dao System.
--
-- The Dao System is free software: you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
-- 
-- The Dao System is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program (see the file called "LICENSE"). If not, see
-- <http://www.gnu.org/licenses/agpl.html>.


{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Dao.Tree where

import           Control.Applicative
import           Control.Monad
import           Control.Monad.Identity
import           Control.Monad.Trans
import           Control.Monad.State

import           Data.Typeable
import           Data.Monoid
import           Data.List (intercalate)
-- import           Data.Binary
import qualified Data.Map as M
import           Data.Word

import Debug.Trace

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

data Tree p n
  = Void
  | Leaf   { branchData :: n }
  | Branch { branchMap  :: M.Map p (Tree p n) }
  | LeafBranch 
    { branchData :: n
    , branchMap  :: M.Map p (Tree p n)
    }
  deriving Typeable
instance (Show p, Show n) => Show (Tree p n) where
  show o = case o of
    Void           -> "voidTree"
    Leaf       o   -> "(leaf "++show o++")"
    Branch       t -> "(branch ["++branch t++"])"
    LeafBranch o t -> "(leaf "++show o++" branch ["++branch t++"])"
    where { branch t = intercalate ", " (M.assocs t  >>= \ (nm, o) -> [show nm++"="++show o]) }
instance (Eq p, Eq n) => Eq (Tree p n) where
  (==) a b = case (a, b) of
    (Void           , Void           ) -> True
    (Leaf       a   , Leaf       b   ) -> a == b
    (Branch     a   , Branch     b   ) -> a == b
    (LeafBranch a aa, LeafBranch b bb) -> a == b && aa == bb
    _                                  -> False
instance (Ord p, Ord n) => Ord (Tree p n) where
  compare a b = case (a, b) of
    (Void           , Void           ) -> EQ
    (Leaf       a   , Leaf       b   ) -> compare a  b
    (Branch       aa, Branch       bb) -> compare aa bb
    (LeafBranch a aa, LeafBranch b bb) -> case compare a b of
      EQ -> compare aa bb
      e  -> e
    (Void           , _              ) -> LT
    (_              , Void           ) -> GT
    (Leaf       _   , _              ) -> LT
    (_              , Leaf       _   ) -> GT
    (Branch       _ , _              ) -> LT
    (_              , Branch       _ ) -> GT
instance Ord p => Functor (Tree p) where
  fmap f tree = case tree of
    Void           -> Void
    Leaf       a   -> Leaf (f a)
    Branch       m -> Branch (fmap (fmap f) m)
    LeafBranch a m -> LeafBranch (f a) (fmap (fmap f) m)
instance (Ord p, Monoid n) => Monoid (Tree p n) where
  mempty  = Void
  mappend = unionWith mappend

-- | A combinator to modify the data in the 'Leaf' and 'LeafBranch' nodes of a tree when passed to
-- one of the functions below.
type ModLeaf     n = Maybe n -> Maybe n

-- | A combinator to modify the data in the 'Branch' and 'LeafBranch' nodes of a tree when passed to
-- one of the functions below.
type ModBranch p n = Maybe (M.Map p (Tree p n)) -> Maybe (M.Map p (Tree p n))

-- | If a 'Tree' is 'Void' or a contains a branch that is equivalent to 'Data.Map.empty',
-- 'Data.Maybe.Nothing' is returned.
notVoid :: Tree p n -> Maybe (Tree p n)
notVoid t = case t of
  Void                      -> Nothing
  Branch       b | M.null b -> Nothing
  LeafBranch a b | M.null b -> Just (Leaf a)
  _                         -> Just t

-- | If the given node is a 'Leaf' or 'LeafBranch', returns the Leaf portion of the node.
getLeaf :: Tree p n -> Maybe n
getLeaf t = case t of { Leaf n -> Just n; LeafBranch n _ -> Just n; _ -> Nothing }

-- | If the given node is a 'Branch' or 'LeafBranch', returns the branch portion of the node.
getBranch :: Tree p a -> Maybe (M.Map p (Tree p a))
getBranch t = case t of { Branch b -> Just b; LeafBranch _ b -> Just b; _ -> Nothing }

-- | Use a 'ModLeaf' function to insert, update, or remove 'Leaf' and 'LeafBranch' nodes.
alterLeaf :: ModLeaf n -> Tree p n -> Tree p n
alterLeaf alt t = maybe Void id $ case t of
  Void           -> alt Nothing         >>= \o -> Just (Leaf o)
  Leaf       o   -> alt (Just o)        >>= \o -> Just (Leaf o)
  Branch       b -> mplus (alt Nothing  >>= \o -> Just (LeafBranch o b)) (Just (Branch b))
  LeafBranch o b -> mplus (alt (Just o) >>= \o -> Just (LeafBranch o b)) (Just (Branch b))

alterBranch :: (Eq p, Ord p) => ModBranch p n -> Tree p n -> Tree p n
alterBranch alt t = maybe Void id $ case t of
  Void           -> alt Nothing         >>= \b -> Just (Branch b)
  Leaf       o   -> mplus (alt Nothing  >>= \b -> Just (LeafBranch o b)) (Just (Leaf o))
  Branch       b -> alt (Just b)        >>= \b -> Just (Branch b)
  LeafBranch o b -> mplus (alt (Just b) >>= \b -> Just (LeafBranch o b)) (Just (Leaf o))

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

data ZipTree p n = ZipTree{ focus :: Tree p n, history :: [(p, Tree p n)] }

newtype UpdateTreeT p n m a = UpdateTreeT{ getUpdateTreeStateT :: StateT (ZipTree p n) m a }
type UpdateTree p n a = UpdateTreeT p n Identity a

instance Monad m =>
  Monad (UpdateTreeT p n m) where
    return = UpdateTreeT . return
    (UpdateTreeT a) >>= b = UpdateTreeT (a >>= getUpdateTreeStateT . b)
instance Functor m =>
  Functor (UpdateTreeT p n m) where { fmap f (UpdateTreeT m) = UpdateTreeT (fmap f m); }
instance (Monad m, Functor m) =>
  Applicative (UpdateTreeT p n m) where { pure = return; (<*>) = ap; }
instance Monad m =>
  MonadState (ZipTree p n) (UpdateTreeT p n m) where { state = UpdateTreeT . state; }
instance MonadTrans (UpdateTreeT p n) where { lift m = UpdateTreeT (lift m); }

-- | Like 'Control.Monad.State.runState', evaluates an 'UpdateTree' monad transformer lifting the
-- 'Control.Monad.Identity.Identity' monad, removing the identity monad after evaluation to give you
-- a pure function.
runUpdateTree :: Ord p => UpdateTree p n a -> Tree p n -> (a, Tree p n)
runUpdateTree updfn = runIdentity . runUpdateTreeT updfn

-- | Like 'Control.Monad.State.execState', disgards the value returned to the 'UpdateTree' monad and
-- only returns the 'Tree'.
execUpdateTree :: Ord p => UpdateTree p n a -> Tree p n -> Tree p n
execUpdateTree updfn = snd . runUpdateTree updfn

-- | Update a 'Tree' using an 'UpdateTreeT' monad, much like how 'Control.Monad.State.runStateT'
-- works. Evaluates to a monadic computation of the lifted type @m@ that 'Control.Monad.return's a
-- pair containing the value last 'Control.Monad.return'ed to the lifted monad and the updated
-- 'Tree'.
runUpdateTreeT :: (Ord p, Functor m, Monad m) => UpdateTreeT p n m a -> Tree p n -> m (a, Tree p n)
runUpdateTreeT updfn tree = fmap (fmap focus) $
  runStateT (getUpdateTreeStateT (updfn >>= \a -> home >> return a)) (ZipTree{focus=tree, history=[]})

-- | Go to the node with the given path. If the path does not exist, it is created.
goto :: (Ord p, Monad m) => [p] -> UpdateTreeT p n m (Tree p n)
goto path = case path of
  []       -> gets focus
  (p:path) -> do
    st <- get
    let step tree = put $ st{focus=tree, history=(p, focus st):history st}
    case getBranch (focus st) >>= M.lookup p of
      Nothing   -> step Void
      Just tree -> step tree
    goto path

-- | Go up one level in the tree, storing the current sub-tree into the upper tree, unless the
{'fraction_non_alphanumeric': 0.13918877706617871, 'fraction_numerical': 0.0010978956999085087, 'mean_word_length': 2.079639368895567, 'pattern_counts': {'":': 0, '<': 11, '<?xml version=': 0, '>': 239, 'https://': 0, 'lorem ipsum': 0, 'www.': 2, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 4, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2830451', 'n_tokens_mistral': 5186, 'n_tokens_neox': 5137, 'n_words': 2228}