suffix trie, Haskell

suffix trie

module Main where

revert :: [a] -> [a]
revert [] = []
revert (a:b) = (revert b) ++ [a]

allChains :: String -> [[Char]] -> [[Char]]
allChains "" product = product
allChains list product =
    allChains (revert . tail $ revert list) $ multiple (head $ revert list) product

multiple :: a -> [[a]] -> [[a]]
multiple a [] = [[a]]
multiple a rhs =
    rhs ++ map (\x -> x ++ [a]) rhs

data Path a = Path a [Path a] | Leaf
    deriving (Show, Eq)

newtype Root a = Root [Path a]
    deriving Show

construct :: [a] -> Path a
construct [a] = Path a [Leaf]
construct (a:b) = Path a [construct b]

mergeOneToGroup :: Eq a => Path a -> [Path a] -> [Path a]
mergeOneToGroup Leaf a
    | (Nothing, _) <- filterFirst ((==) Leaf) a
    = [Leaf] ++ a
    | (Just _, _) <- filterFirst ((==) Leaf) a
    = a
mergeOneToGroup (Path a b) c
    | (Just (Path _ d), left) <- filterFirst (isVal a) c
    = [Path a $ mergeGroup b d] ++ left
    | (_, left) <- filterFirst (isVal a) c
    = [Path a b] ++ left

isVal :: Eq a => a -> (Path a) -> Bool
isVal a (Path b _) = a == b
isVal _ _ = False

filterFirst :: (a -> Bool) -> [a] -> (Maybe a, [a])
filterFirst _ [] = (Nothing, [])
filterFirst f (x:xs) = if f x then (Just x, xs) else insert x $ filterFirst f xs

insert :: a -> (b, [a]) -> (b, [a])
insert a (b, c) = (b, a:c)

mergeGroup :: Eq a => [Path a] -> [Path a] -> [Path a]
mergeGroup a [] = a
mergeGroup [] a = a
mergeGroup a [b] = mergeOneToGroup b a
mergeGroup [a] b = mergeOneToGroup a b
mergeGroup a (b:c) = mergeGroup c $ mergeOneToGroup b a

constructSet :: Eq a => [Path a] -> [Path a]
constructSet [] = []
constructSet (a:b) = mergeOneToGroup a (constructSet b)

suffixTrie :: String -> Root Char
suffixTrie input =
    let
        chains = allChains input []
        path_chains = map construct chains
        rs = constructSet path_chains
    in
        Root rs

main = do
    putStrLn $ "from " ++ "abaaba"
    putStrLn $ "to " ++ (show $ suffixTrie "abaaba")


run \| edit \| history \| help	0