gistfile1.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}

data WithZero

data WithoutZero

data Exp a where
  ExpZero :: Exp WithZero
  ExpOne  :: Exp WithoutZero
  Op21    :: Exp WithoutZero -> Exp WithoutZero -> Exp WithoutZero
  Op2L    :: Exp WithoutZero -> Exp WithZero    -> Exp WithZero
  Op2R    :: Exp WithZero    -> Exp WithoutZero -> Exp WithZero

instance Eq (Exp a) where
  ExpZero    == ExpZero    = True
  ExpOne     == ExpOne     = True
  a `Op21` b == c `Op21` d = a == c && b == d
  a `Op2L` b == c `Op2L` d = a == c && b == d
  a `Op2R` b == c `Op2R` d = a == c && b == d
  _          == _          = False

instance Show (Exp a) where
  show = d  where
    d ExpZero = "0"
    d ExpOne  = "1"
    d (a `Op21` b) = showAB a b
    d (a `Op2L` b) = showAB a b
    d (a `Op2R` b) = showAB a b
    showAB :: Exp a -> Exp b -> String
    showAB a b = "(op2 "++shows a" "++shows b")"

class Op2 a b c where
  op2 :: Exp a -> Exp b -> Exp c

instance Op2 WithoutZero WithoutZero WithoutZero where
  op2 = Op21

instance Op2 WithoutZero WithZero    WithZero where
  op2 = Op2L

instance Op2 WithZero    WithoutZero WithZero where
  op2 = Op2R

e1 :: Exp WithZero
e1 =  op2 ExpZero ExpOne

e2 :: Exp WithoutZero
e2 =  op2 ExpOne ExpOne

-- 正しく型エラーになる
-- e3 =  op2 ExpZero ExpZero

main :: IO ()
main =  print (e1 == e1)