New subject: Layout rule (was Re: PrefixMap: code review request)

27 Feb 2006

      Hi,

I'm a newish Haskell hacker with way too much experience hacking  
Lisp.    At first, I found my Haskell code looking very lisp-y.   I  
think my code is becoming more idiomatic haskell.  I would be very  
grateful to anyone who would take a glance at the code below and  
point out any un-idiomatic usages that jump out.  It's a small module  
from a program which looks for palindromes in a list of words.   
Thanks very much.

Cheers, David

\begin{code}

{-# OPTIONS -O2 -optc-O3 #-}

module PrefixMap (PrefixMap,fromDistinctAscPairList,searchMap)
where
import Data.List
import qualified Data.Map as Map
import Test.HUnit

\end{code}

The PrefixMap datastructure implements a Prefix Tree which allows a
key/value relationship.

\begin{code}

data PrefixMap k v = Node (Maybe v) (Map.Map k (PrefixMap k v))
                      deriving (Show)
\end{code}

A PrefixMap is built from an alphabet enumerating the possible
constituents of keys and a list of pairs of keys and objects. A key
is a string of elements of the alphabet.  The list must be distinct
and in ascending order.  The constraint is not checked.

\begin{code}

fromDistinctAscPairList :: Ord k => [k]->[([k],v)]->PrefixMap k v
fromDistinctAscPairList alphabet pairList =
     build alphabet Nothing (partList pairList alphabet)

partList :: Ord k => [([k],v)]->[k]->[(k,[([k],v)])]
partList pairs alphabet = reverse . fst $ foldl' f ([],pairs) alphabet
     where f (result,pairs) l = (result',rest)
               where (part,rest) = span ((==l) . head . fst) pairs
		    result' = if null part
			         then result
			         else (l,part):result

build :: Ord k => [k]->(Maybe v)->[(k,[([k],v)])]->(PrefixMap k v)
build alphabet val pairs = Node val $ Map.fromDistinctAscList treePairs
     where treePairs = [(c,mkITree l)|(c,l)<-pairs]
	  mkITree l = build alphabet x (partList l' alphabet)
	      where (x,l') = findNode $ snipKeys l

snipKeys :: Ord k => [([k],v)]->[([k],v)]
snipKeys l = [(k,v) | (_:k,v) <- l]

findNode :: Ord k => [([k], v)] -> (Maybe v, [([k], v)])
findNode l = if null suffix
	        then (Nothing,l)
		else ((Just $ snd.head $ suffix),prefix++(tail suffix))
     where (prefix,suffix) = span (not.null.fst) l

\end{code}

searchMap applies a function to each object in the PrefixTree that is
on the path specified by the key and the subtree below it and returns a
list of the results.

\begin{code}

searchMap :: Ord k => (v -> vv) -> [k] -> PrefixMap k v -> [vv]
searchMap f [] t = walk f t []
searchMap f (k:ks) (Node v al) =
     maybe rest ((:rest) . f) v
	where rest = maybe [] (searchMap f ks) (Map.lookup k al)

walk :: (a -> b) -> PrefixMap k a -> [b] -> [b]
walk f (Node Nothing al) z = Map.fold (walk f) z al
walk f (Node (Just x) al) z = Map.fold (walk f) (f x:z) al

test1 = TestCase (do input <- readFile "words.txt"
                      let dict = words input
                          pairs = zip dict dict
                          alpha = ['a'..'z']
                          ftree = fromDistinctAscPairList alpha pairs
                          fAnswer = searchMap id "assert" ftree
                          rtree = fromDistinctAscPairList alpha
                                  $ sort $ zip (map reverse dict) dict
                          rAnswer = searchMap id "tressa" rtree
                      assertEqual "forward search"

["as","ass","assertedly","asserted",

"asserters","asserter","asserting",

"assertions","assertion","assertively",

"assertivenesses","assertiveness",

"assertive","assertors","assertor",
                                       "asserts","assert"]
                                      fAnswer
                      assertEqual "reverse search"
                                      ["reassert","overassert","assert"]
                                      rAnswer
                  )

tests = TestList [TestLabel "Tree Test" test1]
\end{code}
\end{document}

--------------------------------
David F. Place
mailto:d@vidplace.com

PrefixMap: code review request

Brian Hulley

Brian Hulley

Brian Hulley

Brian Hulley

Brian Hulley

Steve Schafer

Brian Hulley

Brian Hulley

Brian Hulley

Brian Hulley

tags

participants (16)