Enforced pattern order

Question

I'm writing a Magic The Gathering (MTG) game engine in Haskell.

For those unfamiliar with MTG, it's a card game where cards can have up to 5 colors: White (W), Blue (U), Black (B), Red (R), and Green (G).

{-# LANGUAGE ViewPatterns #-}
import Data.Set

data Color = W | U | B | R | G
    deriving (Show, Eq, Ord)

data Card = Card (Set Color) -- simplified Card type with only its colors

viewColors :: Card -> [Color]
viewColors (Card colors) = toList colors

---

What I would like to do is pattern match on colors like so:

foo :: Card -> String
foo (viewColors -> [W, B]) = "card is white and black"
foo _ = "whatever"

So far, so good. But there is one problem here: I can type the order of colors incorrectly in the view pattern like so:

bar :: Card -> String
bar (viewColors -> [B, W]) = "this will never get hit"
bar _ = "whatever"

Of course, I could have written viewColors in a way that directly resolves this problem. Or I could use guards, but I'd rather not. Here are a couple ways to do so

viewColors :: Card -> (Bool, Bool, Bool, Bool, Bool)
viewColors (Card colors) = let m = (`member` colors)
    in (m W, m U, m B, m R, m G)

This solution is overly verbose while pattern matching, even if I use a type isomorphic to Bool but with shorter (and/or meaningful) identifiers. Matching a Green card would look like

baz :: Card -> String
baz (viewColors -> (False, False, False, False, True)) = "it's green"

---

data ColorView = W | WU | WUB | ... all combos here

viewColors :: Card -> ColorView
viewColors (Card colors) = extract correct Colorview from colors

This solution has combinatorial explosion. Seems extremely bad to implement, but nice to use, especially if I have a colorViewToList :: ColorView -> [Color] to allow programmatic extraction after the pattern match.

---

I have no idea if the following can be approximated in Haskell, but the following would be ideal:

fuz :: Card -> String
fuz (viewColors -> (W :* ())) = "it's white"
fuz (viewColors -> (W :* U :* ())) = "it's white and blue"
fuz (viewColors -> (W :* B :* ())) = "it's white and black"

---

I'm willing to use advanced language extensions to allow this kind of code: DataKinds, PolyKinds, TypeFamilies, MultiParamTypeClasses, GADTs, you name it.

Is something like this possible? Do you have other suggested approaches?

Answer 1

Main problem is you wish to have permutation instead single value from view. We have only one type which allow permutation - record.

So, we can add new data, record type

data B = F|T -- just shorter name for Bool in patterns
data Palette = P {isW, isU, isB, isR, isG :: B}

bool2b :: Bool -> B
bool2b True  = T
bool2b False = F

viewColors :: Card -> Palette
viewColors (Card colors) = let m = bool2b . (`member` colors)
    in P {isW = m W, isU = m U, isB = m B, isR = m R, isG = m G}

foo :: Card -> String
foo (viewColors -> P {isW=T, isB=T}) = "card is white and black"
foo _ = "whatever"

---

UPDATED

We also could deny wrong patterns. But this solution is more ugly, but it allow use "classic" patterns

{-# LANGUAGE GADTs #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE RankNTypes #-}
data Color = W | U | B | R | G  deriving (Eq)

data W' 
data U' 
data B'
data R'
data G'

data Color' a where
      W' :: Color' W'
      U' :: Color' U'
      B' :: Color' B'
      R' :: Color' R'
      G' :: Color' G'

data M a = N | J a -- just shorter name for Maybe a in patterns

data Palette = Palette 
      (M (Color' W')) 
      (M (Color' U')) 
      (M (Color' B')) 
      (M (Color' R')) 
      (M (Color' G'))

and define viewColor:

viewColors :: Card -> Palette
viewColors (Card colors) = 
  let 
    m :: Color -> Color' a -> M (Color' a)
    m c e = if c `member` colors then J e else N
  in P (m W W') (m U U') (m B B') (m R R') (m G G')

foo :: Card -> String
foo (viewColors -> Palette (J W') N (J B') N N) = 
      "card is white and black"
foo _ = "whatever"

Answer 2

I like the record solution, but it is easy to do with typeclasses

{-# LANGUAGE ViewPatterns, ScopedTypeVariables #-}

import qualified Data.Set as Set

data Color = W' | U' | B' | R' | G' deriving (Show, Eq, Ord)
data Card = Card (Set.Set Color) 

newtype W a = W a
newtype U a = U a
newtype B a = B a
newtype R a = R a
newtype G a = G a

class ToColors x where
  toColors :: x -> [Color]
  reify :: x

instance ToColors () where
  toColors _ = []
  reify = ()

instance ToColors a => ToColors (W a) where
  toColors (W a) = W':toColors a
  reify = W reify

--other instances

members :: Set.Set Color -> [Color] -> Bool
members s = foldl (\b e -> b && (Set.member e s)) True

viewColors :: forall a. ToColors a => Card -> Maybe a
viewColors (Card s) = let a = reify :: a in 
  if members s (toColors a) then (Just a) else Nothing

foo :: Card -> String
foo (viewColors -> Just (W (B ()))) = "card is white and black"
foo _ = "whatever"

this could easily be reworked to get other syntaxes. Like, you could define the colors to be types that don't take parameters, and then use an infix heterogeneous list constructor. Either way it does not care about order.

Edit: if you want to match exact sets that is easy also--just replace the members function like so

viewColors :: forall a. ToColors a => Card -> Maybe a
viewColors (Card s) = let a = reify :: a in 
  if s == (Set.fromList . toColors $ a) then (Just a) else Nothing

Answer 3

EDIT: Further testing shows that this solution does not actually work.

---

You actually don't need any more extensions, I came up with a solution that does what you want, but you'll probably want to optimize it, rename some things, and make it a bit less ugly. You just need to make a new data type and implement Eq yourself and make the operator use infixr:

{-# LANGUAGE ViewPatterns #-}
import Data.Set

data Color = W | U | B | R | G
    deriving (Show, Eq, Ord)

data Card = Card (Set Color) -- simplified Card type with only its colors

-- you may need to fiddle with the precedence here
infixr 0 :*
data MyList a = END | a :* (MyList a) deriving (Show)

myFromList :: [a] -> MyList a
myFromList [] = END
myFromList (x:xs) = x :* myFromList xs

instance Eq a => Eq (MyList a) where
    END == END = True
    END == _   = False
    _   == END = False
    l1  == l2  = allElem l1 l2 && allElem l2 l1
        where
            -- optimize this, otherwise it'll just be really slow
            -- I was just too lazy to write it correctly
            elemMyList :: Eq a => a -> MyList a -> Bool
            elemMyList a ml = case ml of
                END -> False
                (h :* rest) -> if a == h then True else elemMyList a rest
            allElem :: Eq a => MyList a -> MyList a -> Bool
            allElem END l = True
            allElem (h :* rest) l = h `elemMyList` l && allElem rest l

viewColors :: Card -> MyList Color
viewColors (Card colors) = myFromList $ toList colors

fuz :: Card -> String
fuz (viewColors -> (W :* END)) = "it's white"
fuz (viewColors -> (W :* U :* END)) = "it's white and blue"
fuz (viewColors -> (W :* B :* END)) = "it's white and black"
fuz (viewColors -> (W :* B :* R :* END)) = "it's white, black, and red"
fuz (viewColors -> (W :* U :* B :* R :* G :* END)) = "it's all colors"
fuz _ = "I don't know all my colors"

main = do
    putStrLn $ fuz $ Card $ fromList [W, B]
    putStrLn $ fuz $ Card $ fromList [B, W]

---

EDIT: Just fixed the code a bit