2011-09-18 20:02:12 +00:00
|
|
|
{- A generic matcher.
|
|
|
|
-
|
|
|
|
- Can be used to check if a user-supplied condition,
|
|
|
|
- like "foo and ( bar or not baz )" matches. The condition must already
|
|
|
|
- be tokenized, and can contain arbitrary operations.
|
|
|
|
-
|
|
|
|
- If operations are not separated by and/or, they are defaulted to being
|
|
|
|
- anded together, so "foo bar baz" all must match.
|
|
|
|
-
|
|
|
|
- Is forgiving about misplaced closing parens, so "foo and (bar or baz"
|
|
|
|
- will be handled, as will "foo and ( bar or baz ) )"
|
|
|
|
-
|
2023-07-25 16:41:59 +00:00
|
|
|
- Copyright 2011-2023 Joey Hess <id@joeyh.name>
|
2011-09-18 20:02:12 +00:00
|
|
|
-
|
2023-07-25 16:41:59 +00:00
|
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
2011-09-18 20:02:12 +00:00
|
|
|
-}
|
|
|
|
|
2023-07-25 16:41:59 +00:00
|
|
|
{-# LANGUAGE DeriveFoldable, FlexibleContexts #-}
|
2012-10-13 19:17:15 +00:00
|
|
|
|
2011-09-18 20:36:30 +00:00
|
|
|
module Utility.Matcher (
|
2011-09-18 20:02:12 +00:00
|
|
|
Token(..),
|
2014-03-29 19:20:55 +00:00
|
|
|
Matcher(..),
|
2023-07-25 16:41:59 +00:00
|
|
|
MatchDesc(..),
|
2023-07-25 20:11:06 +00:00
|
|
|
MatchResult(..),
|
2019-05-14 17:08:51 +00:00
|
|
|
syntaxToken,
|
2011-09-18 20:32:39 +00:00
|
|
|
generate,
|
importtree: support preferred content expressions needing keys
When importing from a special remote, support preferred content expressions
that use terms that match on keys (eg "present", "copies=1"). Such terms
are ignored when importing, since the key is not known yet.
When "standard" or "groupwanted" is used, the terms in those
expressions also get pruned accordingly.
This does allow setting preferred content to "not (copies=1)" to make a
special remote into a "source" type of repository. Importing from it will
import all files. Then exporting to it will drop all files from it.
In the case of setting preferred content to "present", it's pruned on
import, so everything gets imported from it. Then on export, it's applied,
and everything in it is left on it, and no new content is exported to it.
Since the old behavior on these preferred content expressions was for
importtree to error out, there's no backwards compatability to worry about.
Except that sync/pull/etc will now import where before it errored out.
2023-12-18 20:27:26 +00:00
|
|
|
pruneMatcher,
|
2011-09-18 20:02:12 +00:00
|
|
|
match,
|
2023-07-25 16:41:59 +00:00
|
|
|
match',
|
2011-09-19 00:41:51 +00:00
|
|
|
matchM,
|
2012-10-13 19:17:15 +00:00
|
|
|
matchMrun,
|
2023-07-25 16:41:59 +00:00
|
|
|
matchMrun',
|
2013-05-25 01:33:54 +00:00
|
|
|
isEmpty,
|
2024-09-03 17:49:34 +00:00
|
|
|
findNegated,
|
2015-09-15 16:50:14 +00:00
|
|
|
combineMatchers,
|
2020-09-28 17:22:16 +00:00
|
|
|
introspect,
|
2023-07-25 20:11:06 +00:00
|
|
|
describeMatchResult,
|
2013-05-25 01:33:54 +00:00
|
|
|
|
|
|
|
prop_matcher_sane
|
2011-09-18 20:02:12 +00:00
|
|
|
) where
|
|
|
|
|
2012-03-16 16:28:17 +00:00
|
|
|
import Common
|
2011-09-18 20:02:12 +00:00
|
|
|
|
2023-07-25 16:41:59 +00:00
|
|
|
import Control.Monad.Writer
|
2022-06-29 18:11:20 +00:00
|
|
|
|
2011-09-20 04:49:40 +00:00
|
|
|
{- A Token can be an Operation of an arbitrary type, or one of a few
|
2023-03-14 02:39:16 +00:00
|
|
|
- predefined pieces of syntax. -}
|
2011-09-20 04:49:40 +00:00
|
|
|
data Token op = Operation op | And | Or | Not | Open | Close
|
2011-09-18 20:02:12 +00:00
|
|
|
deriving (Show, Eq)
|
|
|
|
|
2011-09-20 04:49:40 +00:00
|
|
|
data Matcher op = MAny
|
|
|
|
| MAnd (Matcher op) (Matcher op)
|
|
|
|
| MOr (Matcher op) (Matcher op)
|
|
|
|
| MNot (Matcher op)
|
|
|
|
| MOp op
|
2020-09-24 17:55:19 +00:00
|
|
|
deriving (Show, Eq, Foldable)
|
2011-09-18 20:02:12 +00:00
|
|
|
|
2024-09-03 17:49:34 +00:00
|
|
|
newtype MatchDesc = MatchDesc { fromMatchDesc :: String }
|
2023-07-25 20:11:06 +00:00
|
|
|
|
|
|
|
data MatchResult op
|
2023-07-25 17:39:40 +00:00
|
|
|
= MatchedOperation Bool op
|
|
|
|
| MatchedAnd
|
|
|
|
| MatchedOr
|
|
|
|
| MatchedNot
|
|
|
|
| MatchedOpen
|
|
|
|
| MatchedClose
|
|
|
|
deriving (Show, Eq)
|
|
|
|
|
2011-09-20 04:49:40 +00:00
|
|
|
{- Converts a word of syntax into a token. Doesn't handle operations. -}
|
2019-05-14 17:08:51 +00:00
|
|
|
syntaxToken :: String -> Either String (Token op)
|
|
|
|
syntaxToken "and" = Right And
|
|
|
|
syntaxToken "or" = Right Or
|
|
|
|
syntaxToken "not" = Right Not
|
|
|
|
syntaxToken "(" = Right Open
|
|
|
|
syntaxToken ")" = Right Close
|
|
|
|
syntaxToken t = Left $ "unknown token " ++ t
|
2012-10-04 19:48:59 +00:00
|
|
|
|
2011-09-18 20:02:12 +00:00
|
|
|
{- Converts a list of Tokens into a Matcher. -}
|
2011-09-18 20:32:39 +00:00
|
|
|
generate :: [Token op] -> Matcher op
|
2021-01-28 17:50:38 +00:00
|
|
|
generate = simplify . process MAny . implicitAnd . tokenGroups
|
2012-12-13 04:24:19 +00:00
|
|
|
where
|
2013-05-25 01:33:54 +00:00
|
|
|
process m [] = m
|
|
|
|
process m ts = uncurry process $ consume m ts
|
|
|
|
|
2014-04-26 23:25:05 +00:00
|
|
|
consume m (One And:rest) = term (m `MAnd`) rest
|
|
|
|
consume m (One Or:rest) = term (m `MOr`) rest
|
|
|
|
consume m (One Not:rest) = term (\p -> m `MAnd` (MNot p)) rest
|
|
|
|
consume m (One (Operation o):rest) = (m `MAnd` MOp o, rest)
|
2013-05-25 01:33:54 +00:00
|
|
|
consume m (Group g:rest) = (process m g, rest)
|
|
|
|
consume m (_:rest) = consume m rest
|
|
|
|
consume m [] = (m, [])
|
|
|
|
|
2013-05-25 17:50:27 +00:00
|
|
|
term a l =
|
|
|
|
let (p, l') = consume MAny l
|
|
|
|
in (a p, l')
|
|
|
|
|
2013-05-25 01:33:54 +00:00
|
|
|
simplify (MAnd MAny x) = simplify x
|
|
|
|
simplify (MAnd x MAny) = simplify x
|
|
|
|
simplify (MAnd x y) = MAnd (simplify x) (simplify y)
|
|
|
|
simplify (MOr x y) = MOr (simplify x) (simplify y)
|
|
|
|
simplify (MNot x) = MNot (simplify x)
|
|
|
|
simplify x = x
|
|
|
|
|
importtree: support preferred content expressions needing keys
When importing from a special remote, support preferred content expressions
that use terms that match on keys (eg "present", "copies=1"). Such terms
are ignored when importing, since the key is not known yet.
When "standard" or "groupwanted" is used, the terms in those
expressions also get pruned accordingly.
This does allow setting preferred content to "not (copies=1)" to make a
special remote into a "source" type of repository. Importing from it will
import all files. Then exporting to it will drop all files from it.
In the case of setting preferred content to "present", it's pruned on
import, so everything gets imported from it. Then on export, it's applied,
and everything in it is left on it, and no new content is exported to it.
Since the old behavior on these preferred content expressions was for
importtree to error out, there's no backwards compatability to worry about.
Except that sync/pull/etc will now import where before it errored out.
2023-12-18 20:27:26 +00:00
|
|
|
{- Prunes selected ops from the Matcher. -}
|
|
|
|
pruneMatcher :: (op -> Bool) -> Matcher op -> Matcher op
|
|
|
|
pruneMatcher f = fst . go
|
|
|
|
where
|
|
|
|
go MAny = (MAny, False)
|
2023-12-19 01:35:00 +00:00
|
|
|
go (MAnd a b) = go2 a b MAnd
|
|
|
|
go (MOr a b) = go2 a b MOr
|
importtree: support preferred content expressions needing keys
When importing from a special remote, support preferred content expressions
that use terms that match on keys (eg "present", "copies=1"). Such terms
are ignored when importing, since the key is not known yet.
When "standard" or "groupwanted" is used, the terms in those
expressions also get pruned accordingly.
This does allow setting preferred content to "not (copies=1)" to make a
special remote into a "source" type of repository. Importing from it will
import all files. Then exporting to it will drop all files from it.
In the case of setting preferred content to "present", it's pruned on
import, so everything gets imported from it. Then on export, it's applied,
and everything in it is left on it, and no new content is exported to it.
Since the old behavior on these preferred content expressions was for
importtree to error out, there's no backwards compatability to worry about.
Except that sync/pull/etc will now import where before it errored out.
2023-12-18 20:27:26 +00:00
|
|
|
go (MNot a) = case go a of
|
|
|
|
(_, True) -> (MAny, True)
|
|
|
|
(a', False) -> (MNot a', False)
|
|
|
|
go (MOp op)
|
|
|
|
| f op = (MAny, True)
|
|
|
|
| otherwise = (MOp op, False)
|
|
|
|
|
2023-12-19 01:35:00 +00:00
|
|
|
go2 a b g = case (go a, go b) of
|
|
|
|
((_, True), (_, True)) -> (MAny, True)
|
|
|
|
((a', False), (b', False)) -> (g a' b', False)
|
|
|
|
((_, True), (b', False)) -> (b', False)
|
|
|
|
((a', False), (_, True)) -> (a', False)
|
|
|
|
|
2013-05-25 01:33:54 +00:00
|
|
|
data TokenGroup op = One (Token op) | Group [TokenGroup op]
|
|
|
|
deriving (Show, Eq)
|
|
|
|
|
|
|
|
tokenGroups :: [Token op] -> [TokenGroup op]
|
|
|
|
tokenGroups [] = []
|
|
|
|
tokenGroups (t:ts) = go t
|
2012-12-13 04:24:19 +00:00
|
|
|
where
|
2014-10-09 18:53:13 +00:00
|
|
|
go Open =
|
2013-05-25 01:33:54 +00:00
|
|
|
let (gr, rest) = findClose ts
|
|
|
|
in gr : tokenGroups rest
|
|
|
|
go Close = tokenGroups ts -- not picky about missing Close
|
|
|
|
go _ = One t : tokenGroups ts
|
2011-09-20 04:49:40 +00:00
|
|
|
|
2013-05-25 01:33:54 +00:00
|
|
|
findClose :: [Token op] -> (TokenGroup op, [Token op])
|
|
|
|
findClose l =
|
|
|
|
let (g, rest) = go [] l
|
|
|
|
in (Group (reverse g), rest)
|
|
|
|
where
|
2014-10-09 18:53:13 +00:00
|
|
|
go c [] = (c, []) -- not picky about extra Close
|
unify exception handling into Utility.Exception
Removed old extensible-exceptions, only needed for very old ghc.
Made webdav use Utility.Exception, to work after some changes in DAV's
exception handling.
Removed Annex.Exception. Mostly this was trivial, but note that
tryAnnex is replaced with tryNonAsync and catchAnnex replaced with
catchNonAsync. In theory that could be a behavior change, since the former
caught all exceptions, and the latter don't catch async exceptions.
However, in practice, nothing in the Annex monad uses async exceptions.
Grepping for throwTo and killThread only find stuff in the assistant,
which does not seem related.
Command.Add.undo is changed to accept a SomeException, and things
that use it for rollback now catch non-async exceptions, rather than
only IOExceptions.
2014-08-08 01:55:44 +00:00
|
|
|
go c (t:ts) = dispatch t
|
2013-05-25 01:33:54 +00:00
|
|
|
where
|
unify exception handling into Utility.Exception
Removed old extensible-exceptions, only needed for very old ghc.
Made webdav use Utility.Exception, to work after some changes in DAV's
exception handling.
Removed Annex.Exception. Mostly this was trivial, but note that
tryAnnex is replaced with tryNonAsync and catchAnnex replaced with
catchNonAsync. In theory that could be a behavior change, since the former
caught all exceptions, and the latter don't catch async exceptions.
However, in practice, nothing in the Annex monad uses async exceptions.
Grepping for throwTo and killThread only find stuff in the assistant,
which does not seem related.
Command.Add.undo is changed to accept a SomeException, and things
that use it for rollback now catch non-async exceptions, rather than
only IOExceptions.
2014-08-08 01:55:44 +00:00
|
|
|
dispatch Close = (c, ts)
|
|
|
|
dispatch Open =
|
2013-05-25 01:33:54 +00:00
|
|
|
let (c', ts') = go [] ts
|
|
|
|
in go (Group (reverse c') : c) ts'
|
unify exception handling into Utility.Exception
Removed old extensible-exceptions, only needed for very old ghc.
Made webdav use Utility.Exception, to work after some changes in DAV's
exception handling.
Removed Annex.Exception. Mostly this was trivial, but note that
tryAnnex is replaced with tryNonAsync and catchAnnex replaced with
catchNonAsync. In theory that could be a behavior change, since the former
caught all exceptions, and the latter don't catch async exceptions.
However, in practice, nothing in the Annex monad uses async exceptions.
Grepping for throwTo and killThread only find stuff in the assistant,
which does not seem related.
Command.Add.undo is changed to accept a SomeException, and things
that use it for rollback now catch non-async exceptions, rather than
only IOExceptions.
2014-08-08 01:55:44 +00:00
|
|
|
dispatch _ = go (One t:c) ts
|
2011-09-18 20:02:12 +00:00
|
|
|
|
2021-01-28 17:50:38 +00:00
|
|
|
implicitAnd :: [TokenGroup op] -> [TokenGroup op]
|
|
|
|
implicitAnd [] = []
|
|
|
|
implicitAnd [v] = [v]
|
|
|
|
implicitAnd (a:b:rest) | need a && need b = a : One And : implicitAnd (b:rest)
|
|
|
|
where
|
|
|
|
need (One (Operation _)) = True
|
|
|
|
need (Group _) = True
|
|
|
|
need _ = False
|
|
|
|
implicitAnd (a:rest) = a : implicitAnd rest
|
|
|
|
|
2011-09-18 20:02:12 +00:00
|
|
|
{- Checks if a Matcher matches, using a supplied function to check
|
|
|
|
- the value of Operations. -}
|
2011-09-18 21:47:24 +00:00
|
|
|
match :: (op -> v -> Bool) -> Matcher op -> v -> Bool
|
2023-07-25 16:41:59 +00:00
|
|
|
match a m v = fst $ runWriter $ match' a m v
|
|
|
|
|
|
|
|
{- Like match, but accumulates a description of why it did or didn't match. -}
|
2023-07-25 20:11:06 +00:00
|
|
|
match' :: (op -> v -> Bool) -> Matcher op -> v -> Writer [MatchResult op] Bool
|
2023-07-25 16:41:59 +00:00
|
|
|
match' a m v = matchMrun' m (\op -> pure (a op v))
|
2011-09-18 20:02:12 +00:00
|
|
|
|
2011-09-18 20:32:39 +00:00
|
|
|
{- Runs a monadic Matcher, where Operations are actions in the monad. -}
|
2011-09-18 21:47:24 +00:00
|
|
|
matchM :: Monad m => Matcher (v -> m Bool) -> v -> m Bool
|
2023-07-25 16:41:59 +00:00
|
|
|
matchM m v = matchMrun m $ \op -> op v
|
2011-09-19 00:41:51 +00:00
|
|
|
|
2012-10-13 19:17:15 +00:00
|
|
|
{- More generic running of a monadic Matcher, with full control over running
|
2023-07-25 16:41:59 +00:00
|
|
|
- of Operations. -}
|
|
|
|
matchMrun :: Monad m => Matcher op -> (op -> m Bool) -> m Bool
|
|
|
|
matchMrun m run = fst <$> runWriterT (matchMrun' m run)
|
|
|
|
|
2023-07-25 20:11:06 +00:00
|
|
|
{- Like matchMrun, but accumulates a description of why it did or didn't match. -}
|
2023-07-25 16:41:59 +00:00
|
|
|
matchMrun'
|
2023-07-25 20:11:06 +00:00
|
|
|
:: (MonadWriter [MatchResult op] (t m), MonadTrans t, Monad m)
|
2023-07-25 16:41:59 +00:00
|
|
|
=> Matcher op
|
|
|
|
-> (op -> m Bool)
|
|
|
|
-> t m Bool
|
|
|
|
matchMrun' m run = go m
|
2012-12-13 04:24:19 +00:00
|
|
|
where
|
|
|
|
go MAny = return True
|
2023-07-25 16:41:59 +00:00
|
|
|
go (MAnd m1 m2) = do
|
2023-07-25 17:39:40 +00:00
|
|
|
tell [MatchedOpen]
|
2023-07-25 16:41:59 +00:00
|
|
|
r1 <- go m1
|
|
|
|
if r1
|
|
|
|
then do
|
|
|
|
tell [MatchedAnd]
|
2023-07-25 17:39:40 +00:00
|
|
|
r <- go m2
|
|
|
|
tell [MatchedClose]
|
|
|
|
return r
|
|
|
|
else do
|
|
|
|
tell [MatchedClose]
|
|
|
|
return False
|
2023-07-25 16:41:59 +00:00
|
|
|
go (MOr m1 m2) = do
|
2023-07-25 17:39:40 +00:00
|
|
|
tell [MatchedOpen]
|
2023-07-25 16:41:59 +00:00
|
|
|
r1 <- go m1
|
|
|
|
if r1
|
2023-07-25 17:39:40 +00:00
|
|
|
then do
|
|
|
|
tell [MatchedClose]
|
|
|
|
return True
|
2023-07-25 16:41:59 +00:00
|
|
|
else do
|
|
|
|
tell [MatchedOr]
|
2023-07-25 17:39:40 +00:00
|
|
|
r <- go m2
|
|
|
|
tell [MatchedClose]
|
|
|
|
return r
|
2023-07-25 16:41:59 +00:00
|
|
|
go (MNot m1) = do
|
2023-07-25 17:39:40 +00:00
|
|
|
tell [MatchedOpen, MatchedNot]
|
|
|
|
r <- liftM not (go m1)
|
|
|
|
tell [MatchedClose]
|
|
|
|
return r
|
2023-07-25 16:41:59 +00:00
|
|
|
go (MOp op) = do
|
|
|
|
r <- lift (run op)
|
2023-07-25 17:39:40 +00:00
|
|
|
tell [MatchedOperation r op]
|
2023-07-25 16:41:59 +00:00
|
|
|
return r
|
2012-10-08 17:16:53 +00:00
|
|
|
|
2012-12-06 17:22:16 +00:00
|
|
|
{- Checks if a matcher contains no limits. -}
|
|
|
|
isEmpty :: Matcher a -> Bool
|
|
|
|
isEmpty MAny = True
|
|
|
|
isEmpty _ = False
|
2013-05-25 01:33:54 +00:00
|
|
|
|
2024-09-03 17:49:34 +00:00
|
|
|
{- Finds terms within the matcher that are negated.
|
|
|
|
- Terms that are doubly negated are not returned. -}
|
|
|
|
findNegated :: Matcher op -> [op]
|
|
|
|
findNegated = go False []
|
|
|
|
where
|
|
|
|
go _ c MAny = c
|
|
|
|
go n c (MAnd a b) = go n (go n c a) b
|
|
|
|
go n c (MOr a b) = go n (go n c a) b
|
|
|
|
go n c (MNot m) = go (not n) c m
|
|
|
|
go n c (MOp o)
|
|
|
|
| n = (o:c)
|
|
|
|
| otherwise = c
|
|
|
|
|
2015-09-15 16:50:14 +00:00
|
|
|
{- Combines two matchers, yielding a matcher that will match anything
|
2015-09-15 17:12:21 +00:00
|
|
|
- both do. But, if one matcher contains no limits, yield the other one. -}
|
2015-09-15 16:50:14 +00:00
|
|
|
combineMatchers :: Matcher a -> Matcher a -> Matcher a
|
|
|
|
combineMatchers a b
|
|
|
|
| isEmpty a = b
|
|
|
|
| isEmpty b = a
|
|
|
|
| otherwise = a `MOr` b
|
|
|
|
|
2020-09-28 17:22:16 +00:00
|
|
|
{- Checks if anything in the matcher meets the condition. -}
|
|
|
|
introspect :: (a -> Bool) -> Matcher a -> Bool
|
|
|
|
introspect = any
|
|
|
|
|
2023-07-25 20:11:06 +00:00
|
|
|
{- Converts a [MatchResult] into a description of what matched and didn't
|
2023-07-26 18:34:21 +00:00
|
|
|
- match. Returns Nothing when the matcher didn't contain any operations
|
|
|
|
- and so matched by default. -}
|
|
|
|
describeMatchResult :: (op -> Bool -> MatchDesc) -> [MatchResult op] -> String -> Maybe String
|
|
|
|
describeMatchResult _ [] _ = Nothing
|
|
|
|
describeMatchResult descop l prefix = Just $
|
|
|
|
prefix ++ unwords (go $ simplify True l)
|
2023-07-25 17:39:40 +00:00
|
|
|
where
|
|
|
|
go [] = []
|
2023-07-25 20:11:06 +00:00
|
|
|
go (MatchedOperation b op:rest) =
|
|
|
|
let MatchDesc d = descop op b
|
|
|
|
in d : go rest
|
2023-07-25 17:39:40 +00:00
|
|
|
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
|
|
|
|
|
2024-04-06 13:50:58 +00:00
|
|
|
-- Remove unnecessary outermost parens
|
2023-07-25 17:39:40 +00:00
|
|
|
simplify True (MatchedOpen:rest) = case lastMaybe rest of
|
2023-07-26 19:07:29 +00:00
|
|
|
Just MatchedClose -> simplify False (dropFromEnd 1 rest)
|
2023-07-25 17:39:40 +00:00
|
|
|
_ -> 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
|
2023-07-26 19:28:57 +00:00
|
|
|
-- or (foo) => or foo
|
|
|
|
simplify _ (MatchedOr:MatchedOpen:o@(MatchedOperation {}):MatchedClose:rest) =
|
|
|
|
MatchedOr:o:simplify False rest
|
|
|
|
-- and (foo) => and foo
|
|
|
|
simplify _ (MatchedAnd:MatchedOpen:o@(MatchedOperation {}):MatchedClose:rest) =
|
|
|
|
MatchedAnd:o:simplify False rest
|
2023-07-25 17:39:40 +00:00
|
|
|
-- (not foo) => not foo
|
|
|
|
simplify _ (MatchedOpen:MatchedNot:o@(MatchedOperation {}):MatchedClose:rest) =
|
|
|
|
MatchedNot:o:simplify False rest
|
2023-07-25 17:55:01 +00:00
|
|
|
-- ((foo bar)) => (foo bar)
|
|
|
|
simplify _ (MatchedOpen:MatchedOpen:rest) =
|
|
|
|
MatchedOpen : simplify False (removeclose (0 :: Int) rest)
|
2023-07-25 17:39:40 +00:00
|
|
|
simplify _ (v:rest) = v : simplify False rest
|
|
|
|
simplify _ v = v
|
|
|
|
|
2023-07-25 17:55:01 +00:00
|
|
|
removeclose n (MatchedOpen:rest) =
|
|
|
|
MatchedOpen : removeclose (n+1) rest
|
|
|
|
removeclose n (MatchedClose:rest)
|
|
|
|
| n > 0 = MatchedClose : removeclose (n-1) rest
|
|
|
|
| otherwise = rest
|
|
|
|
removeclose n (v:rest) = v : removeclose n rest
|
|
|
|
removeclose _ [] = []
|
|
|
|
|
2013-05-25 01:33:54 +00:00
|
|
|
prop_matcher_sane :: Bool
|
2021-01-28 17:50:38 +00:00
|
|
|
prop_matcher_sane = and
|
|
|
|
[ all (\m -> match (\b _ -> b) m ()) (map generate evaltrue)
|
|
|
|
, all (\(x,y) -> generate x == generate y) evalsame
|
2013-05-25 01:33:54 +00:00
|
|
|
]
|
|
|
|
where
|
2021-01-28 17:50:38 +00:00
|
|
|
evaltrue =
|
|
|
|
[ [Operation True]
|
|
|
|
, []
|
|
|
|
, [Operation False, Or, Operation True, Or, Operation False]
|
|
|
|
, [Operation True, Or, Operation True]
|
|
|
|
, [Operation True, And, Operation True]
|
|
|
|
, [Not, Open, Operation True, And, Operation False, Close]
|
|
|
|
, [Not, Open, Not, Open, Not, Operation False, Close, Close]
|
|
|
|
, [Not, Open, Not, Open, Not, Open, Not, Operation True, Close, Close]
|
|
|
|
, [Operation True, And, Not, Operation False]
|
|
|
|
, [Operation True, Not, Operation False]
|
|
|
|
, [Operation True, Not, Not, Not, Operation False]
|
|
|
|
, [Operation True, Not, Not, Not, Operation False, And, Operation True]
|
|
|
|
, [Operation True, Not, Not, Not, Operation False, Operation True]
|
|
|
|
, [Not, Open, Operation True, And, Operation False, Close,
|
|
|
|
And, Open,
|
|
|
|
Open, Operation True, And, Operation False, Close,
|
|
|
|
Or,
|
|
|
|
Open, Operation True, And, Open, Not, Operation False, Close, Close,
|
|
|
|
Close, And,
|
|
|
|
Open, Not, Operation False, Close]
|
|
|
|
]
|
|
|
|
evalsame =
|
|
|
|
[
|
|
|
|
( [Operation "foo", Open, Operation "bar", Or, Operation "baz", Close]
|
|
|
|
, [Operation "foo", And, Open, Operation "bar", Or, Operation "baz", Close]
|
|
|
|
)
|
|
|
|
,
|
|
|
|
( [Operation "foo", Not, Open, Operation "bar", Or, Operation "baz", Close]
|
|
|
|
, [Operation "foo", And, Not, Open, Operation "bar", Or, Operation "baz", Close]
|
|
|
|
)
|
|
|
|
,
|
|
|
|
( [Open, Operation "bar", Or, Operation "baz", Close, Operation "foo"]
|
|
|
|
, [Open, Operation "bar", Or, Operation "baz", Close, And, Operation "foo"]
|
|
|
|
)
|
|
|
|
,
|
|
|
|
( [Open, Operation "bar", Or, Operation "baz", Close, Not, Operation "foo"]
|
|
|
|
, [Open, Operation "bar", Or, Operation "baz", Close, And, Not, Operation "foo"]
|
|
|
|
)
|
|
|
|
,
|
|
|
|
( [Operation "foo", Operation "bar"]
|
|
|
|
, [Operation "foo", And, Operation "bar"]
|
|
|
|
)
|
|
|
|
,
|
|
|
|
( [Operation "foo", Not, Operation "bar"]
|
|
|
|
, [Operation "foo", And, Not, Operation "bar"]
|
|
|
|
)
|
|
|
|
]
|