```{-# LANGUAGE
GeneralizedNewtypeDeriving #-}
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)

{-|
A class for types that compose similar to wildcards.

All instances must satisfy the following:

* @match@ defines a partial order; @top@ is the top element of this order
and @intersect@ is a meet.

* Meets are exact: if @match x y@ and @match x z@, then
@match x (fromJust (intersect y z))@, if such a meet exists.

Minimal complete definition: top and intersect.
-}
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 -- shorter prefix
width = bitSize v1 -- value ignored
mask = complement (bit (width - sig) - 1) in -- mask out lower bits
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
```