module Frenetic.Pattern
( Matchable (..)
, Wildcard (..)
, Prefix (..)
, wMatch
) where
import Data.List hiding (intersect)
import Data.Bits
import Data.Word
import Data.Maybe
import Numeric (showHex)
class (Eq a) => Matchable a where
top :: a
intersect :: a -> a -> Maybe a
match :: a -> a -> Bool
overlap :: a -> a -> Bool
disjoint :: a -> a -> Bool
match x y = intersect x y == Just x
overlap x y = isJust $ intersect x y
disjoint x y = isNothing $ intersect x y
data Wildcard a
= Exact a
| Wildcard
deriving (Ord, Eq)
data Prefix a = Prefix a Int
deriving (Ord, Eq)
instance Show a => Show (Wildcard a) where
show Wildcard = "*"
show (Exact a) = show a
instance Functor Wildcard where
fmap f (Exact a) = Exact (f a)
fmap _ Wildcard = Wildcard
instance (Bits a, Show a) => Show (Prefix a) where
show (Prefix val significantBits) =
if bitSize val == significantBits
then show val
else "Prefix " ++ show val ++ " " ++ show significantBits
instance Bits a => Matchable (Prefix a) where
top = Prefix 0 0
intersect (Prefix v1 sig1) (Prefix v2 sig2) =
let sig = min sig1 sig2
width = bitSize v1
mask = complement (bit (width sig) 1) in
if v1 .&. mask == v2 .&. mask
then
if sig1 > sig2
then Just (Prefix v1 sig1)
else Just (Prefix v2 sig2)
else Nothing
instance Eq a => Matchable (Wildcard a) where
top = Wildcard
intersect (Exact a) (Exact b) = if a == b then Just (Exact a) else Nothing
intersect (Exact a) Wildcard = Just (Exact a)
intersect Wildcard (Exact b) = Just (Exact b)
intersect Wildcard Wildcard = Just Wildcard
wMatch :: Eq a => a -> Wildcard a -> Bool
wMatch b w = Exact b `match` w