Arbitrary constructor exhaustiveness check with TH and GHC.Generics

ExhaustivenessCheck.hs

{-# LANGUAGE StandaloneDeriving, DeriveGeneric, TypeFamilies, TypeSynonymInstances, FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module ExhaustivenessCheck where

import Language.Haskell.TH
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH

import Control.Lens (toListOf)
import Data.Word
import Generics.Deriving.Lens (tinplate)
import GHC.Generics

--deriving instance Generic (Ratio Integer)
--deriving instance Generic TH.Module
--deriving instance Generic TH.Role
--deriving instance Generic TH.TySynEqn
--deriving instance Generic TH.AnnTarget
--deriving instance Generic TH.AnnLookup
--deriving instance Generic TH.ModuleInfo
deriving instance Generic TH.Loc
deriving instance Generic TH.Name
deriving instance Generic TH.ModName
deriving instance Generic TH.PkgName
deriving instance Generic TH.NameSpace
deriving instance Generic TH.Info
deriving instance Generic TH.Type
deriving instance Generic TH.TyLit
deriving instance Generic TH.TyVarBndr
deriving instance Generic TH.Pred
deriving instance Generic TH.Lit
deriving instance Generic TH.Range
deriving instance Generic TH.Stmt
deriving instance Generic TH.Pat
deriving instance Generic TH.Exp
deriving instance Generic TH.Dec
deriving instance Generic TH.Guard
deriving instance Generic TH.Body
deriving instance Generic TH.Match
deriving instance Generic TH.Fixity
deriving instance Generic TH.FamFlavour
deriving instance Generic TH.FunDep
deriving instance Generic TH.RuleBndr
deriving instance Generic TH.Phases
deriving instance Generic TH.RuleMatch
deriving instance Generic TH.Inline
deriving instance Generic TH.Pragma
deriving instance Generic TH.Safety
deriving instance Generic TH.Callconv
deriving instance Generic TH.Foreign
deriving instance Generic TH.Strict
deriving instance Generic TH.FixityDirection
deriving instance Generic TH.OccName
deriving instance Generic TH.Con
deriving instance Generic TH.Clause


-- Integer
data D_Integer
data C_Integer

instance Datatype D_Integer where
  datatypeName _ = "Integer"
  moduleName _ = "GHC.Integer"

instance Constructor C_Integer where
  conName _ = "" -- JPM: I'm not sure this is the right implementation...

instance Generic Integer where
  type Rep Integer = D1 D_Integer (C1 C_Integer (S1 NoSelector (Rec0 Integer)))
  from x = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = x


-- Word8
data D_Word8
data C_Word8

instance Datatype D_Word8 where
  datatypeName _ = "Word8"
  moduleName _ = "Data.Word"

instance Constructor C_Word8 where
  conName _ = "" -- JPM: I'm not sure this is the right implementation...

instance Generic Word8 where
  type Rep Word8 = D1 D_Word8 (C1 C_Word8 (S1 NoSelector (Rec0 Word8)))
  from x = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = x


-- Rational
data D_Rational
data C_Rational

instance Datatype D_Rational where
  datatypeName _ = "Rational"
  moduleName _ = "Data.Ratio"

instance Constructor C_Rational where
  conName _ = "" -- JPM: I'm not sure this is the right implementation...

instance Generic Rational where
  type Rep Rational = D1 D_Rational (C1 C_Rational (S1 NoSelector (Rec0 Rational)))
  from x = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = x


-- TH.NameFlavour
data D_NameFlavour
data C_NameFlavour

instance Datatype D_NameFlavour where
  datatypeName _ = "NameFlavour"
  moduleName _ = "Language.Haskell.TH.Syntax"

instance Constructor C_NameFlavour where
  conName _ = "" -- JPM: I'm not sure this is the right implementation...

instance Generic TH.NameFlavour where
  type Rep TH.NameFlavour = D1 D_NameFlavour (C1 C_NameFlavour (S1 NoSelector (Rec0 TH.NameFlavour)))
  from x = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = x


conNameOf :: Con -> Name
conNameOf con = case con of
  NormalC name _ -> name
  RecC name _ -> name
  InfixC _ name _ -> name
  ForallC _ _ con' -> conNameOf con'

exhaustivenessCheck :: Name -> Q Exp -> Q Exp
exhaustivenessCheck tyName qList = do
  tyInfo <- reify tyName
  let conNames = case tyInfo of
        TyConI (DataD _cxt _name _tyVarBndrs cons _derives) -> map conNameOf cons
        _ -> fail "exhaustivenessCheck: Can only handle simple data declarations"

  list <- qList
  case list of
    input@(ListE l) -> do
      -- We could be more specific by searching for `ConE`s in `l`
      let cons = toListOf tinplate l :: [Name]
      case filter (`notElem` cons) conNames of
        [] -> return input
        missings -> fail $ "exhaustivenessCheck: missing case: " ++ show missings
    _ -> fail "exhaustivenessCheck: argument must be a list"

test.hs

{-# LANGUAGE TemplateHaskell #-}

import Control.Applicative
import Test.QuickCheck

import ExhaustivenessCheck


data Mytype
  = C1
  | C2 Char
  | C3 Int String
  deriving (Eq, Ord, Show)


--x = [| [ pure C1
-- , C2 <$> arbitrary
-- , C3 <$> arbitrary <*> arbitrary
-- ]
-- |]

--y = oneof $(exhaustivenessCheck x)


y :: Gen Mytype
y = oneof $(exhaustivenessCheck ''Mytype [|
    [ pure C1
    , C2 <$> arbitrary
    , C3 <$> arbitrary <*> arbitrary
    ]
  |])