[Haskell] export proper functions and add a SelfPath parser & some us…

…eful short functions (see https://gist.github.com/1175234)

Implementations/Haskell/Data/SelfML.hs

@@ -1,10 +1,23 @@
 module Data.SelfML (
   Tree(Node, Terminal),
   Forest,
+  children,
   withChildren,
+  value,
+  withValue,
+  isTerminal,
+  isNode,
   readSML,
   showSML,
-  prettyPrintSML) where
+  prettyPrintSML,
+  SelfPath(..),
+  Query(..),
+  filterSelfPath,
+  mapSelfPath,
+  parseSelfPath,
+  (<//>),
+  (<$/>),
+  transformSML) where
 
 import Control.Applicative
 import Data.Char
@@ -59,16 +72,17 @@ showSMLString s
 
 data Query = Named String
            | Equal (Tree String)
-           | Try   (Tree String -> Bool)
            | Child
            | At    Integer
            | Not   Query
+           deriving (Eq, Read, Show)
 
 data SelfPath = Recursive  Query    SelfPath
               | Direct     Query    SelfPath
               | Lookahead  SelfPath SelfPath
               | NLookahead SelfPath SelfPath
               | Anything
+              deriving (Eq, Read, Show)
 
 instance Monoid SelfPath where
   mempty                      = Anything
@@ -78,57 +92,27 @@ instance Monoid SelfPath where
   NLookahead q sp `mappend` b = NLookahead q (sp `mappend` b)
   Anything        `mappend` b = b
 
-deepQuery :: Query -> Tree String -> Forest String
-deepQuery q n@(Node _ ts) = shallowQuery q n ++ (ts >>= deepQuery q)
-deepQuery q n             = shallowQuery q n
-
-shallowQuery :: Query -> Tree String -> Forest String
-shallowQuery      (Named s)  (Node _ ts)  = filter f ts
-  where f (Node x _) = x == s
-        f _          = False
-shallowQuery (Not (Named s)) (Node _ ts)  = filter f ts
-  where f (Node x _) = x /= s
-        f _          = False
-shallowQuery      (Equal t)  (Node _ ts)  = filter (== t)    ts
-shallowQuery (Not (Equal t)) (Node _ ts)  = filter (/= t)    ts
-shallowQuery      (Try   p)  (Node _ ts)  = filter p         ts
-shallowQuery (Not (Try   p)) (Node _ ts)  = filter (not . p) ts
-shallowQuery      (At    0)  (Terminal x) = [Terminal x]
-shallowQuery      (At    0)  (Node x _)   = [Terminal x]
-shallowQuery (Not (At    0)) (Node _ ts)  = ts
-shallowQuery      (At    i)  (Node _ ts)
-  | genericLength ts >= i                 = [ts `genericIndex` (i-1)]
-shallowQuery (Not (At    i)) (Node _ ts)
-  | genericLength ts >= i                 = genericTake (i - 1) ts ++ genericDrop i ts
-shallowQuery      Child      (Node _ ts)  = ts
-shallowQuery (Not Child)     _            = []
-shallowQuery (Not (Not q))   t            = shallowQuery q t
-shallowQuery _         _                  = []
-
-deepMapQuery :: Query -> (Tree String -> Tree String) -> Tree String -> Tree String
-deepMapQuery q f = withChildren (map $ deepMapQuery q f) . shallowMapQuery q f
-
-shallowMapQuery :: Query -> (Tree String -> Tree String) -> Tree String -> Tree String
-shallowMapQuery      (Named s)  f t = withChildren (map fn) t
-  where fn n@(Node x _) | x == s    = f n
-        fn n                        = n
-shallowMapQuery (Not (Named s)) f t = withChildren (map fn) t
-  where fn n@(Node x _) | x /= s    = f n
-        fn n                        = n
-shallowMapQuery      (Equal e)  f t = withChildren (map $ applyIf (== e)    f) t
-shallowMapQuery (Not (Equal e)) f t = withChildren (map $ applyIf (/= e)    f) t
-shallowMapQuery      (Try   p)  f t = withChildren (map $ applyIf        p  f) t
-shallowMapQuery (Not (Try   p)) f t = withChildren (map $ applyIf (not . p) f) t
-shallowMapQuery      (At    0)  f t = withValue (value.f.Terminal) t
-shallowMapQuery (Not (At    0)) f t = withChildren (map f) t
-shallowMapQuery      (At    i)  f t = withChildren (\ xs -> snd $ foldl fn (genericLength xs - 1, []) xs) t
-  where fn (c, l) a | c == i        = (c-1, f a : l)
-                    | otherwise     = (c-1,   a : l)
-shallowMapQuery (Not (At    i)) f t = withChildren (\ xs -> snd $ foldl fn (genericLength xs - 1, []) xs) t
-  where fn (c, l) a | c /= i        = (c-1, f a : l)
-                    | otherwise     = (c-1,   a : l)
-shallowMapQuery      Child      f t = withChildren (map f) t
-shallowMapQuery (Not Child)     f t = t
+(<//>) :: Forest String                     -- ^ Forest to match against
+       -> String                            -- ^ SelfPath to compile
+       -> Either ParseError (Forest String) -- ^ Result of the filter operation
+f <//> sp = case parseSelfPath sp of
+              Left err       -> Left err
+              Right Anything -> Right f
+              Right sp'      -> Right (filterSelfPath sp' (Node "" f))
+
+(<$/>) :: (Tree String -> Tree String)      -- ^ Map function
+       -> String                            -- ^ SelfPath to compile
+       -> Forest String                     -- ^ Forest to match & map over
+       -> Either ParseError (Forest String) -- ^ Result of the map operation
+f <$/> sp = \ fo -> cs . ($ Node "" fo) . ($ f) . mapSelfPath <$> parseSelfPath sp
+  where cs (Node "" ts) = ts
+        cs n@_          = [n]
+
+transformSML :: (Tree String -> Tree String) -- ^ Map function
+             -> String                       -- ^ SelfPath to compile
+             -> String                       -- ^ Serialized SelfML text to transform
+             -> Either ParseError String     -- ^ Pretty-printed transformation if successful
+transformSML f sp i = prettyPrintSML <$> (readSML i >>= f <$/> sp)
 
 filterSelfPath :: SelfPath -> Tree String -> Forest String
 filterSelfPath (Recursive  q  sp) t = deepQuery    q t >>= filterSelfPath sp
@@ -152,6 +136,9 @@ mapSelfPath (NLookahead ie sp) f t = if null (filterSelfPath ie t)
                                         else t
 mapSelfPath Anything           f t = f t
 
+parseSelfPath :: String -> Either ParseError SelfPath
+parseSelfPath = parse (spSpaces spNode <* eof) ""
+
 --- parser ---
 
 smlForest :: Parsec [Char] () (Forest String)
@@ -175,10 +162,36 @@ braceHash p = string "{#" *> p <* string "#}"
 backticks p = char   '`'  *> p <* char   '`'
 
 spaces   p = whitespace *> p <* whitespace
-whitespace = many (smlLineComment <|> smlComment <|> satisfy isSpace *> pure ())
+whitespace = many (smlLineComment <|> smlComment <|> satisfy isSpace *> pure ()) *> pure ()
 
 satisfyNone fs = satisfy $ \ c -> not $ any ($ c) fs
 
+--- SelfPath parser ---
+
+spNode :: Parsec [Char] () SelfPath
+
+spNode = try (lah       <$> many (char '!') <*> parens (spNode) <*> sn)
+     <|>      Direct    <$> (char '>' *> spWhitespace *> spQuery) <*> sn
+     <|>      Recursive <$> spQuery                             <*> sn
+  where sn = try (spWhitespace *> spNode) <|> pure Anything
+        lah excl ie sp =
+          (if even (length excl) then Lookahead else NLookahead) ie sp
+
+spQuery = spNot
+      <|> spEqual
+      <|> spAt
+      <|> spChild
+      <|> spNamed
+
+spNot   = Not   <$> (char '!' *> spQuery)
+spEqual = Equal <$> (char '=' *> smlTree)
+spAt    = At    <$> (char '#' *> (read <$> many1 (oneOf ['0'..'9'])))
+spChild = char '*' *> pure Child
+spNamed = Named <$> smlString
+
+spWhitespace = many (smlComment <|> satisfy isSpace *> pure ())
+spSpaces p   = spWhitespace *> p <* spWhitespace
+
 --- various utility functions for trees ---
 
 instance Functor Tree where
@@ -205,17 +218,76 @@ withValue :: (a -> a) -> Tree a -> Tree a
 withValue f (Node x ts)  = Node (f x) ts
 withValue f (Terminal x) = Terminal (f x)
 
--- helpers --
+--- SelfPath Query Magic ---
+
+-- | Recursively matches a query through a tree.
+deepQuery :: Query -> Tree String -> Forest String
+deepQuery q n@(Node _ ts) = shallowQuery q n ++ (ts >>= deepQuery q)
+deepQuery q n             = shallowQuery q n
+
+-- | Matches a query on the top level of a tree.
+shallowQuery :: Query -> Tree String -> Forest String
+shallowQuery      (Named s)  (Node _ ts)  = filter f ts
+  where f (Node x _) = x == s
+        f _          = False
+shallowQuery (Not (Named s)) (Node _ ts)  = filter f ts
+  where f (Node x _) = x /= s
+        f _          = False
+shallowQuery      (Equal t)  (Node _ ts)  = filter (== t)    ts
+shallowQuery (Not (Equal t)) (Node _ ts)  = filter (/= t)    ts
+shallowQuery      (At    0)  (Terminal x) = [Terminal x]
+shallowQuery      (At    0)  (Node x _)   = [Terminal x]
+shallowQuery (Not (At    0)) (Node _ ts)  = ts
+shallowQuery      (At    i)  (Node _ ts)
+  | genericLength ts >= i                 = [ts `genericIndex` (i-1)]
+shallowQuery (Not (At    i)) (Node _ ts)
+  | genericLength ts >= i                 = genericTake (i - 1) ts ++ genericDrop i ts
+shallowQuery      Child      (Node _ ts)  = ts
+shallowQuery (Not Child)     _            = []
+shallowQuery (Not (Not q))   t            = shallowQuery q t
+shallowQuery _         _                  = []
+
+-- | Recursively maps a query through a tree.
+deepMapQuery :: Query -> (Tree String -> Tree String) -> Tree String -> Tree String
+deepMapQuery q f = withChildren (map $ deepMapQuery q f) . shallowMapQuery q f
+
+-- | Maps a query through the top level of a tree.
+shallowMapQuery :: Query -> (Tree String -> Tree String) -> Tree String -> Tree String
+shallowMapQuery      (Named s)  f t = withChildren (map fn) t
+  where fn n@(Node x _) | x == s    = f n
+        fn n                        = n
+shallowMapQuery (Not (Named s)) f t = withChildren (map fn) t
+  where fn n@(Node x _) | x /= s    = f n
+        fn n                        = n
+shallowMapQuery      (Equal e)  f t = withChildren (map $ applyIf (== e)    f) t
+shallowMapQuery (Not (Equal e)) f t = withChildren (map $ applyIf (/= e)    f) t
+shallowMapQuery      (At    0)  f t = withValue (value.f.Terminal) t
+shallowMapQuery (Not (At    0)) f t = withChildren (map f) t
+shallowMapQuery      (At    i)  f t = withChildren (\ xs -> snd $ foldl fn (genericLength xs - 1, []) xs) t
+  where fn (c, l) a | c == i        = (c-1, f a : l)
+                    | otherwise     = (c-1,   a : l)
+shallowMapQuery (Not (At    i)) f t = withChildren (\ xs -> snd $ foldl fn (genericLength xs - 1, []) xs) t
+  where fn (c, l) a | c /= i        = (c-1, f a : l)
+                    | otherwise     = (c-1,   a : l)
+shallowMapQuery      Child      f t = withChildren (map f) t
+shallowMapQuery (Not Child)     f t = t
+
+--- helpers ---
 
 singleton x = [x]
 
 indent n = (replicate n ' ' ++) . concatMap (\c -> case c of
                                                 '\n' -> '\n' : replicate n ' '
                                                 _    -> [c])
 
+-- | 'True' if the node is 'Terminal'.
 isTerminal (Terminal _) = True
 isTerminal _            = False
+
+-- | 'True' if the node is 'Node'.
 isNode                  = not . isTerminal
 
+-- | Applies the function to the argument if and only if the predicate
+--   matches the argument, otherwise simply returns the argument.
 applyIf p f x | p x       = f x
               | otherwise = x