Get index of constructor in its type declaration.

ConIndex.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}

module ConIndex (conIndex) where

import           Data.List (findIndex)
import           Language.Haskell.TH (Con (..), Dec (DataD), ExpQ,
                                      Info (DataConI, TyConI), Name, ParentName,
                                      integerL, litE, reify)

-- | Get index of constructor in its type declaration.
-- An alternative to 'fromEnum' for the case of complicated constructors like
-- @... = Foo Bar | Baz Qux IORef@.
--
-- Result is an integer literal expression.
--
-- >>> $(conIndex 'Nothing)
-- 0
-- >>> $(conIndex 'Just)
-- 1
conIndex :: Name -> ExpQ
conIndex name = do
    nameInfo <- reify name
    typeName <- case nameInfo of
        DataConI _ _ (typeName :: ParentName) _ -> pure typeName
        _ ->
            fail . unwords $
            [ "conIndex: argument is expected to be a data constructor name,"
            , "but it is", show nameInfo
            ]
    typeInfo <- reify typeName
    typeDeclaration <- case typeInfo of
        TyConI (typeDeclaration :: Dec) -> pure typeDeclaration
        _ ->
            fail . unwords $
            [ "conIndex: argument is expected to be a data constructor name,"
            , "but it is a constructor of", show typeInfo
            ]
    cons <- case typeDeclaration of
        DataD _ _ _ (cons :: [Con]) _ -> pure cons
        _ ->
            fail . unwords $
            [ "conIndex: argument is expected to be a data constructor name,"
            , "but it is a constructor of type", show typeDeclaration
            ]
    i <-
        case findIndex ((name ==) . conName) cons of
            Nothing ->
                fail . unwords $
                [ "conIndex: Impossible! Didn't find constructor", show name
                , "in its data declaration", show typeName
                ]
            Just i -> pure i
    litE . integerL $ toInteger i

conName :: Con -> Name
conName = \case
    NormalC   name _    -> name
    RecC      name _    -> name
    InfixC    _ name _  -> name
    ForallC   _ _ con   -> conName con