Ternary search tree. See at: http://programmingpraxis.com/2009/06/05/ternary-search-tries/

pp_ternary_search.hs

{-# LANGUAGE TupleSections, RecordWildCards #-}
 
import Prelude hiding (lookup)
import Control.Arrow (first)
 
data TTree k v = TTree {val :: !(Maybe v), node :: !(TNode k v)} deriving Show
data TNode k v = Empty | Node {key :: !k, lch, eqch, rch :: !(TTree k v)} deriving Show
 
empty :: TTree k v
empty = TTree Nothing Empty
 
modify :: Ord k => ([k] -> TTree k v -> TTree k v) ->
                    [k] -> TNode k v -> TNode k v
modify f (k:ks) n@(Node {..}) = case compare k key of
    LT -> n {lch = f (k:ks) lch}
    GT -> n {rch = f (k:ks) rch}
    EQ -> n {eqch = f ks eqch}
modify f _ _ = undefined
 
delete :: Ord k => [k] -> TTree k v -> TTree k v
delete [] t = t {val = Nothing}
delete ks t = t {node = case node t of
    Empty -> Empty
    n     -> modify delete ks n}
 
update :: Ord k => [k] -> v -> (v -> v) ->
                    TTree k v -> TTree k v
update [] v f t = t {val = Just $ maybe v f (val t)}
update ks v f t = case node t of
    Empty -> insert ks v empty {val = val t}
    n     -> t { node = modify (\k -> update k v f) ks n }
 
insert :: Ord k => [k] -> v -> TTree k v -> TTree k v
insert [] v t = t { val = Just v }
insert (k:ks) v t = t {node = case node t of
    Empty -> Node k empty (insert ks v empty) empty
    n     -> modify (flip insert v) (k:ks) n}
 
lookup :: Ord k => [k] -> TTree k v -> Maybe v
lookup [] t = val t
lookup (k:ks) t = case node t of
    Empty     -> Nothing
    Node {..} -> case compare k key of
        LT -> lookup (k:ks) lch
        GT -> lookup (k:ks) rch
        EQ -> lookup ks eqch
 
enlist :: Ord k => TTree k v -> [([k], v)]
enlist (TTree {..}) = maybe [] ((:[]).([],)) val ++ case node of
    Empty     -> []
    Node {..} -> concat [enlist lch, map (first (key:)) (enlist eqch), enlist rch]