parenthesize match description as needed to avoid ambiguity

While avoiding most unncessary parens.

Once case where unncessary parens are not avoided is:

	not ( ( not foo and baz ) )

It would be good eventually to remove doubled parens like these.

Sponsored-by: Dartmouth College's DANDI project

diff --git a/Utility/Matcher.hs b/Utility/Matcher.hs
index 81ff97cbb52d90032f469d9e903160c8c924c1d6..3ef8397ce62d7f1d7bfabb95d7a4e4f1db229c37 100644 (file)
--- a/Utility/Matcher.hs
+++ b/Utility/Matcher.hs
@@ -31,6 +31,7 @@ module Utility.Matcher (
        isEmpty,
        combineMatchers,
        introspect,
+       describeMatchDesc,
 
        prop_matcher_sane
 ) where
@@ -51,6 +52,15 @@ data Matcher op = MAny
        | MOp op
        deriving (Show, Eq, Foldable)
 
+data MatchDesc op
+       = MatchedOperation Bool op
+       | MatchedAnd
+       | MatchedOr
+       | MatchedNot
+       | MatchedOpen
+       | MatchedClose
+       deriving (Show, Eq)
+
 {- Converts a word of syntax into a token. Doesn't handle operations. -}
 syntaxToken :: String -> Either String (Token op)
 syntaxToken "and" = Right And
@@ -128,14 +138,6 @@ implicitAnd (a:rest) = a : implicitAnd rest
 match :: (op -> v -> Bool) -> Matcher op -> v -> Bool
 match a m v = fst $ runWriter $ match' a m v
 
-data MatchDesc op
-       = MatchedOperation op
-       | UnmatchedOperation op
-       | MatchedAnd
-       | MatchedOr
-       | MatchedNot
-       deriving (Show, Eq)
-
 {- Like match, but accumulates a description of why it did or didn't match. -}
 match' :: (op -> v -> Bool) -> Matcher op -> v -> Writer [MatchDesc op] Bool
 match' a m v = matchMrun' m (\op -> pure (a op v))
@@ -159,27 +161,37 @@ matchMrun' m run = go m
   where
        go MAny = return True
        go (MAnd m1 m2) = do
+               tell [MatchedOpen]
                r1 <- go m1
                if r1 
                        then do
                                tell [MatchedAnd]
-                               go m2
-                       else return False
+                               r <- go m2
+                               tell [MatchedClose]
+                               return r
+                       else do
+                               tell [MatchedClose]
+                               return False
        go (MOr m1 m2) = do
+               tell [MatchedOpen]
                r1 <- go m1
                if r1
-                       then return True
+                       then do
+                               tell [MatchedClose]
+                               return True
                        else do
                                tell [MatchedOr]
-                               go m2
+                               r <- go m2
+                               tell [MatchedClose]
+                               return r
        go (MNot m1) = do
-               tell [MatchedNot]
-               liftM not (go m1)
+               tell [MatchedOpen, MatchedNot]
+               r <- liftM not (go m1)
+               tell [MatchedClose]
+               return r
        go (MOp op) = do
                r <- lift (run op)
-               if r
-                       then tell [MatchedOperation op]
-                       else tell [UnmatchedOperation op]
+               tell [MatchedOperation r op]
                return r
 
 {- Checks if a matcher contains no limits. -}
@@ -199,6 +211,35 @@ combineMatchers a b
 introspect :: (a -> Bool) -> Matcher a -> Bool
 introspect = any
 
+{- Converts a [MatchDesc] into a description of what matched and didn't
+ - match. -}
+describeMatchDesc :: (op -> Bool -> String) -> [MatchDesc op] -> String
+describeMatchDesc descop = unwords . go . simplify True
+  where
+       go [] = []
+       go (MatchedOperation b op:rest) = descop op b : go rest
+       go (MatchedAnd:rest) = "and" : go rest
+       go (MatchedOr:rest) = "or" : go rest
+       go (MatchedNot:rest) = "not" : go rest
+       go (MatchedOpen:rest) = "(" : go rest
+       go (MatchedClose:rest) = ")" : go rest
+
+       -- Remove unncessary outermost parens
+       simplify True (MatchedOpen:rest) = case lastMaybe rest of
+               Just MatchedClose -> simplify True (dropFromEnd 1 rest)
+               _ -> simplify False rest
+       -- (foo or bar) or baz => foo or bar or baz
+       simplify _ (MatchedOpen:o1@(MatchedOperation {}):MatchedOr:o2@(MatchedOperation {}):MatchedClose:MatchedOr:rest) = 
+               o1:MatchedOr:o2:MatchedOr:simplify False rest
+       -- (foo and bar) and baz => foo and bar and baz
+       simplify _ (MatchedOpen:o1@(MatchedOperation {}):MatchedAnd:o2@(MatchedOperation {}):MatchedClose:MatchedAnd:rest) = 
+               o1:MatchedAnd:o2:MatchedAnd:simplify False rest
+       -- (not foo) => not foo
+       simplify _ (MatchedOpen:MatchedNot:o@(MatchedOperation {}):MatchedClose:rest) =
+               MatchedNot:o:simplify False rest
+       simplify _ (v:rest) = v : simplify False rest
+       simplify _ v = v
+
 prop_matcher_sane :: Bool
 prop_matcher_sane = and
        [ all (\m -> match (\b _ -> b) m ()) (map generate evaltrue)