Generic typeclass machinery to reason about functors ignoring their arguments

structuralEquality.hs

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-} -- Only needed for the DSL example

import GHC.Generics

-- Data types that are constant and uninteresting
class Eq a => Const a
    -- laws
    -- a == b = true

instance Const () 
--instance Const (Proxy a)

-- Equality disregarding contents
class FEq f where
    feq :: f a -> f b -> Bool
    
    default feq :: (Generic1 f, FEq (Rep1 f)) => f a -> f b -> Bool
    feq a b = feq (from1 a) (from1 b)
    
-- Constant disregarding contents
class FEq f => FConst f
    -- laws:
    -- feq f g = True 
    
instance (FEq a, FEq b) => FEq (a :*: b) where
    feq (a1 :*: b1) (a2 :*: b2) = feq a1 a2 && feq b1 b2

instance (FConst a, FConst b) => FConst (a :*: b)
    
instance (FEq a, FEq b) => FEq (a :+: b) where
    feq (L1 a1) (L1 a2) = feq a1 a2
    feq (R1 b1) (R1 b2) = feq b1 b2
    feq _       _       = False
    
instance (FEq a) => FEq (M1 i c a) where
    feq (M1 a1) (M1 a2) = feq a1 a2
    
instance (FConst a) => FConst (M1 i c a)

instance (FEq a, FConst b) => FEq (a :.: b) where
    feq (Comp1 a1) (Comp1 a2) = feq a1 a2
    
instance (FConst a, FConst b) => FConst (a :.: b)

instance (FEq a) => FEq (Rec1 a) where
    feq (Rec1 a1) (Rec1 a2) = feq a1 a2
    
instance (Eq a) => FEq (K1 i a) where
    feq (K1 a1) (K1 a2) = a1 == a2
    
instance FEq U1 where
    feq U1 U1 = True
    
instance FConst U1
    
instance (Const a) => FConst (K1 i a) where

instance FEq Par1 where
    feq (Par1 _) (Par1 _) = True
    
instance FConst Par1

-- Equality instances for base types
instance Eq a => FEq ((,) a)
instance Const a => FConst ((,) a)
instance (Eq a, Eq b) => FEq ((,,) a b)
instance (Const a, Const b) => FConst ((,,) a b)
-- Add more instances for the higher arity tuples
instance FEq ([])
instance FEq Maybe
instance Eq a => FEq (Either a)

-- Is there a missing Generic1 instance for Proxy?
-- instance FEq Proxy
-- instance FConst Proxy

instance FEq ((->) a) where
    feq _ _ = True
    
instance FConst ((->) a)

-- Show data, disregarding contents
class FShow f where
    fshowsPrec :: Int -> f a -> ShowS
    
    default fshowsPrec :: (Generic1 f, FShow (Rep1 f)) => Int -> f a -> ShowS
    fshowsPrec p f = fshowsPrec p (from1 f)
    
fshow f = fshowsPrec 0 f []

instance (FShow a, FShow b) => FShow (a :*: b) where
    fshowsPrec p (a :*: b) = fshowsPrec p a . showChar ' ' . fshowsPrec p b
    
instance (FShow a, FShow b) => FShow (a :+: b) where
    fshowsPrec p (L1 a) = fshowsPrec p a
    fshowsPrec p (R1 b) = fshowsPrec p b
    
instance (FShow a, FConst b) => FShow (a :.: b) where
    fshowsPrec p (Comp1 a) = fshowsPrec p a
    
instance (FShow a) => FShow (Rec1 a) where
    fshowsPrec p (Rec1 a) = fshowsPrec p a
    
instance (Show a) => FShow (K1 i a) where
    fshowsPrec p (K1 a) = showsPrec p a
    
instance FShow U1 where
    fshowsPrec p U1 = id
    
instance FShow Par1 where
    fshowsPrec p (Par1 _) = showChar '_'
    
instance (FShow a, Constructor c) => FShow (M1 C c a) where
    fshowsPrec p c@(M1 a) = 
        let empty = null $ fshowsPrec 10 a []
        in showParen (p >= 10 && not empty) $ showString (conName c) . if empty then id else showChar ' ' . fshowsPrec 10 a

instance (FShow a) => FShow (M1 D d a) where
    fshowsPrec p (M1 a) = fshowsPrec p a

instance (FShow a) => FShow (M1 S s a) where
    fshowsPrec p (M1 a) = fshowsPrec p a
    
-- Show instances for base types    
data Blank = Blank

instance Show Blank where
    showsPrec p Blank = showChar '_'
    
instance FShow ([]) where
    fshowsPrec p xs = showsPrec p (map (const Blank) xs)
    
instance Show a => FShow ((,) a) where
    fshowsPrec p (a,_) = showsPrec p (a,Blank)

instance (Show a, Show b) => FShow ((,,) a b) where
    fshowsPrec p (a,b,_) = showsPrec p (a,b,Blank)
    
-- More instances for higher arity tuplbes
    
instance FShow ((->) a) where
    fshowsPrec p _ = showChar '_'
    
instance FShow Maybe
instance Show a => FShow (Either a)
    
-- An example from a stack overflow question    
data DSL next
    = Prompt String (String -> next)
    | Repeat Int String next
    | Display String next
    deriving (Generic1)
    
instance FEq DSL
instance FShow DSL
    
main = do
    print $ (1, 2) `feq` (1, 3)
    print $ (2, 2) `feq` (1, 3)
    print $ (1, 2, 3) `feq` (1, 2, 4)
    print $ ['a'..'c'] `feq` [1..3]
    print $ ['a'..'c'] `feq` [1..4]
    print $ fshow ['a'..'c']
    print $ fshow ('a', 2, 7)
    print $ Prompt "Hello" undefined `feq` Prompt "Hello" undefined
    print $ Prompt "Hello" undefined `feq` Repeat 10 "Hello" undefined
    print $ Prompt "Hello" undefined `feq` Prompt "Helllo" undefined
    putStrLn . fshow $ Prompt "Hello" undefined