[CLI and Trie not needed jupdike@gmail.com**20080211173343] { hunk ./CLI.lhs 1 -COMMENT:----------------------- - -o Zus"atzliche Funktionen f"ur die Verarbeitung von Argumenten? -------------------------------- - -Generic command line interpreter - - -> module CLI ( commandLineInterpreter, -> commandLineInterpreterWithHelp, -> exit, unknown -> ) -> where - - - - - > import LibPosix - > import LibSystem - -> import System -> import System.IO -> import System.IO.Error - - > import Support ( ljustify ) - - > import IOSupport ( getLine, putLine ) - - - -> import Sort ( mergeSort ) -> import Trie ( Trie, fromList, prefixLookup ) - -> spaces n = take n (repeat ' ') - -> ljustify :: Int -> String -> String -> ljustify n s = s ++ spaces (n - length s) - - -Command line interpreter - - -> commandLineInterpreter -> :: [Char] -- prompt -> -> [([[Char]], st -> [[Char]] -> IO st)]-- list of commands -> -> (st -> [Char] -> IO st) -- default command -> -> st -- initial state -> -> IO () - - - - -> commandLineInterpreter prompt cmdList defCmd st0 -> = loop st0 -> where -> cmdTable = fromList [ (x, cmd) | (xs, cmd)<-cmdList, x<-xs ] -> loop st = --installHandler sigINT (Catch (handle st)) Nothing >> -> putStr prompt >> -> catch getLine bye >>= \line -> -> case words line of -> [] -> -> loop st -> x@(cmd:args) -> -> case prefixLookup cmdTable cmd of -> [] -> -> try (defCmd st (unwords x)) >>= -> either -> (\err -> putStrLn (show err) >> -> loop st) -> (\st' -> loop st') -> [(_, act)] -> -> try (act st args) >>= -> either -> (\err -> putStrLn (show err) >> -> loop st) -> (\st' -> loop st') -> _ -> -> putStrLn "\BELambiguous command" >> -> loop st -> handle st = putStrLn "<>" >> -> loop st - - - -> bye error = do -> eof <- isEOF -> if eof -> then do putStrLn "\nlogout" -> exit -> else do putStrLn (show error) -> exitWith (ExitFailure 1) - - > bye EOF = putStrLn "\nlogout" >> - > exit - > bye err = putStrLn (show err) >> - > exitWith (ExitFailure 1) - - - -Command line interpreter with help facility - - -> commandLineInterpreterWithHelp -> :: [Char] -- prompt -> -> [([[Char]], [Char], [Char], -- list of commands -> st -> [[Char]] -> IO st)] -> -> (st -> [Char] -> IO st) -- default command -> -> st -- initial state -> -> IO () - - - - -> commandLineInterpreterWithHelp prompt cmdList -> = commandLineInterpreter prompt -> [ (xs, cmd) | (xs, _, _, cmd)<-cmdList' ] -> where -> cmdList' = help:cmdList -> helpList = [ (replace '%' s1 x, s2) | (xs, s1, s2, _)<-cmdList', x<-xs ] -> help = (["help", "?"], "%", "display this page", -> \st _ -> -> sequence [ putStrLn s -> | s<-mergeSort (beside2 helpList) ] >> -> return st) - - - -Additional functions - - -> exit :: IO a -> exit = exitWith ExitSuccess - - - - -> unknown :: st -> [Char] -> IO st -> unknown st _ = putStrLn "\BELunknown command" >> -> return st - - - -Auxiliary definitions - - - > catch :: IO a -> (IOError13 -> IO a) -> IO a - > catch a f = try a >>= either f return - - -Der Aufruf replace c s t ersetzt das Zeichen c im String s durch den String t. AUSNAHME: dem Zeichen c geht das Escape-Zeichen c (ohne - - -> replace :: Char -> [Char] -> [Char] -> [Char] -> replace c s t = run s -> where -> run [] = [] -> run s@[a] -> | a == c = t -> | otherwise = s -> run (a:x@(b:x')) -> | a == '\\' && b == c = c:run x' -> | a == c = t ++ run x -> | otherwise = a:run x - - - - -> beside2 xys = [ ljustify m x ++ y | (x, y)<-xys ] -> where m = 4 + maximum [ length x | (x, _)<-xys] - - rmfile ./CLI.lhs hunk ./Main.lhs 11 -> import CLI hunk ./Trie.lhs 1 -COMMENT:----------------------- - -Compile me with - ghc -c -O -fglasgow-exts Trie.lhs -------------------------------- - -Tries - - -> module Trie ( Trie, -> -- construction -> empty, singleton, union, unionMany, -> add, (///), -> -- construction with combining function -> -- modification -> delete, deleteMany, minus, -> -- conversion -> toList, fromList, -> -- size -> genericLengthTrie, lengthTrie, -> -- testing -> nullTrie, isSingleton, -> -- extraction -> elemsTrie, indicesTrie, -> -- lookup -> lookup, lookupWithDefault, -> lookupWithContinuation, -> -- *additional functions* -> prefixLookup -> ) -> where - - - - -> import Subsequences ( isPrefixOf ) - -> applyWithDefault :: (a -> Maybe b) -> b -> a -> b -> applyWithDefault f def a = case f a of Nothing -> def; Just v -> v - - - - -> applyWithContinuation :: (a -> Maybe b) -> (b -> c) -> c -> a -> c -> applyWithContinuation f succ err a -> = case f a of Nothing -> err; Just v -> succ v - - - - > import Support ( applyWithDefault, applyWithContinuation ) - - - -Type definition - - -> data Trie a b = Leaf [a] b -- leaf node -> | Node [(a,Trie a b)] (Maybe b) -- inner node -> deriving () - - -The value associated with the empty sequence is contained in the Maybe b part. Note: Node [('a',empty)] Nothing is not legal. A trie is printed as a set of bindings of the form a |-> v. - - -> instance (Show a, Show b) => Show (Trie a b) where -> showsPrec d t = showBinds (toList t) -> where showBinds [] = showString "{}" -> showBinds (b:x) = showChar '{' . showBind b . showl x -> showl [] = showChar '}' -> showl (b:x) = showString ", " . showBind b . showl x -> showBind (a,v) = shows a . showString " |-> " . shows v - - -Further instances: Eq, Ord, ...? - -Construction -empty constructs an empty trie. - - -> empty :: Trie a b -> empty = Node [] Nothing - - - - -> singleton :: ([a],b) -> Trie a b -> singleton (x,v) = Leaf x v - - -union and unionMany are quick hacks. - - -> union :: Ord a => Trie a b -> Trie a b -> Trie a b -> union t1 t2 = t1 /// toList t2 - - - - -> unionMany :: Ord a => [Trie a b] -> Trie a b -> unionMany = foldl union empty - - - - -> add :: Ord a => ([a],b) -> Trie a b -> Trie a b -> add (x,v) t = insert t x v - - -Note: /// instead of //. - - -> (///) :: Ord a => Trie a b -> [([a],b)] -> Trie a b -> t /// xvs = foldl (flip add) t xvs - - - -Construction with combining function -ToDo: union_C, unionMany_C, add_C, addMany_C. - -Modification -ToDo: intersect. - - -> delete :: Ord a => Trie a b -> [a] -> Trie a b -> delete t@(Leaf y w) x -> | x==y = empty -> | otherwise = t -> delete (Node ts w) [] = Node ts Nothing -> delete (Node ts w) (a:x) = Node (delList ts) w -> where -> delList [] = [] -> delList ts@((b,t):us) = case compare b a of -> LT -> (b,t):delList us -> EQ -> case delete t x of -> Node [] Nothing -> us -- rm empty node -> u -> (b,u):us -> GT -> ts - - - - -> deleteMany :: Ord a => Trie a b -> [[a]] -> Trie a b -> deleteMany = foldl delete - - -minus is a quick hack. - - -> minus :: Ord a => Trie a b -> Trie a b -> Trie a b -> minus t1 t2 = t1 `deleteMany` indicesTrie t2 - - -ToDo: amap, partition, filter, foldl, foldr. - -Conversion - - -> toList :: Trie a b -> [([a],b)] -> toList t = toLists [] t [] - - - - -> toLists s (Leaf x v) = put (reverseTo s x, v) -> toLists s (Node ts w) = puts [ (reverse s, v) | Just v<-[w] ] -> . compose [ toLists (a:s) t | (a,t)<-ts ] - - -toList (Leaf x w) = [ (x,w) ] toList (Node ts w) = [ ([],v) | Just v<-[w] ] ++ [ (a:x,w) | (a,t)<-ts, (x,w)<-toList t ] fromList is a quick hack. - - -> fromList :: Ord a => [([a],b)] -> Trie a b -> fromList = foldl (flip add) empty - - - -Size -Note: genericLengthTrie instead of genericLength. Dito: lengthTrie. - - -> genericLengthTrie :: Integral a => Trie b c -> a -> genericLengthTrie (Leaf x w) = 1 -> genericLengthTrie (Node ts w) = sum [ genericLengthTrie t | (a,t)<-ts ]+len w -> where len Nothing = 0 -> len (Just _) = 1 - - - - -> lengthTrie :: Trie a b -> Int -> lengthTrie = genericLengthTrie - - - -Testing -Note: nullTrie instead of null. - - -> nullTrie :: Trie a b -> Bool -> nullTrie (Node [] Nothing) = True -> nullTrie _ = False - - - - -> isSingleton :: Trie a b -> Bool -> isSingleton (Leaf x v) = True -> isSingleton (Node [] (Just v)) = True -> isSingleton (Node [(a,t)] Nothing) = isSingleton t -> isSingleton _ = False - - -ToDo: intersecting, subsetT. - -Extraction -Note: elemsTrie instead of elems. Dito: indicesTrie. - - -> elemsTrie :: Trie a b -> [b] -> elemsTrie = map snd . toList - - - - -> indicesTrie :: Trie a b -> [[a]] -> indicesTrie = map fst . toList - - - -Lookup - - -> tlookup :: Ord a => Trie a b -> [a] -> Maybe b -> tlookup (Leaf y w) x -> | x==y = Just w -> | otherwise = Nothing -> tlookup (Node ts w) [] = w -> tlookup (Node ts w) (a:x) = lookupList ts -> where -> lookupList [] = Nothing -> lookupList ((b,t):ts) = case compare b a of -> LT -> lookupList ts -> EQ -> tlookup t x -> GT -> Nothing - - - - -> lookupWithDefault :: Ord a => Trie a b -> b -> [a] -> b -> lookupWithDefault = applyWithDefault . tlookup - - - - -> lookupWithContinuation :: Ord a => Trie a b -> (b -> c) -> c -> [a] -> c -> lookupWithContinuation = applyWithContinuation . tlookup - - - -Additional functions -prefixLookup returns the list of all completions of the given list. - - -> prefixLookup :: Ord a => Trie a b -> [a] -> [([a],b)] -> prefixLookup (Leaf y w) x = [ (drop (length x) y,w) | x `isPrefixOf` y ] -> prefixLookup t@(Node _ _) [] = toList t -> prefixLookup (Node ts _) (a:x)= lookupList ts -> where -> lookupList [] = [] -> lookupList ((b,t):ts) = case compare b a of -> LT -> lookupList ts -> EQ -> prefixLookup t x -> GT -> [] - - - -Auxiliary functions -Insert an element into a trie. An existing entry is shadowed by the new entry. - - -> insert :: Ord a => Trie a b -> [a] -> b -> Trie a b -> insert (Leaf [] _) [] v = Leaf [] v -> insert (Leaf (b:y) w) [] v = Node [(b,Leaf y w)] (Just v) -> insert (Leaf [] w) (a:x) v = Node [(a,Leaf x v)] (Just w) -> insert (Leaf (b:y) w) (a:x) v = case compare b a of -> LT -> Node [(b,Leaf y w),(a,Leaf x v)] Nothing -> EQ -> Node [(a,insert (Leaf y w) x v)] Nothing -> GT -> Node [(a,Leaf x v),(b,Leaf y w)] Nothing -> insert (Node ts w) [] v = Node ts (Just v) -> insert (Node ts w) (a:x) v = Node (insList ts) w -> where -> insList [] = [(a,Leaf x v)] -> insList ((b,t):ts) = case compare b a of -> LT -> (b,t):insList ts -> EQ -> (b,insert t x v):ts -> GT -> (a,Leaf x v):(b,t):ts - - - - -> compose = foldr (.) id - - - - -> put = (:) -> puts = (++) - - - - -> reverseTo [] y = y -> reverseTo (a:x) y = reverseTo x (a:y) - - rmfile ./Trie.lhs }