content: -----------------------------------------------------------------------------
  -- |
  -- Module      :  Data.Singletons.TH.Deriving.Enum
  -- Copyright   :  (C) 2015 Richard Eisenberg
  -- License     :  BSD-style (see LICENSE)
  -- Maintainer  :  Ryan Scott
  -- Stability   :  experimental
  -- Portability :  non-portable
  --
  -- Implements deriving of Enum instances
  --
  ----------------------------------------------------------------------------
  
  module Data.Singletons.TH.Deriving.Enum ( mkEnumInstance ) where
  
  import Language.Haskell.TH.Syntax
  import Language.Haskell.TH.Ppr
  import Language.Haskell.TH.Desugar
  import Data.Singletons.TH.Deriving.Util
  import Data.Singletons.TH.Names
  import Data.Singletons.TH.Syntax
  import Data.Singletons.TH.Util
  import Control.Monad
  import Data.Maybe
  
  -- monadic for failure only
  mkEnumInstance :: DsMonad q => DerivDesc q
  mkEnumInstance mb_ctxt ty (DataDecl _ _ _ cons) = do
    -- GHC only allows deriving Enum instances for enumeration types (i.e., those
    -- data types whose constructors all lack fields). We perform the same
    -- validity check here.
    --
    -- GHC actually goes further than we do. GHC will give a specific error
    -- message if you attempt to derive an instance for a "non-vanilla" data
    -- type—that is, a data type that uses features not expressible with
    -- Haskell98 syntax, such as existential quantification. Checking whether
    -- a type variable is existentially quantified is difficult in Template
    -- Haskell, so we omit this check.
    when (null cons ||
          any (\(DCon _ _ _ f _) -> not (null $ tysOfConFields f)) cons) $
      fail ("Can't derive Enum instance for " ++ pprint (typeToTH ty) ++ ".")
  
    n <- qNewName "n"
    let to_enum = UFunction [DClause [DVarP n] (to_enum_rhs cons [0..])]
        to_enum_rhs [] _ = DVarE errorName `DAppE` DLitE (StringL "toEnum: bad argument")
        to_enum_rhs (DCon _ _ name _ _ : rest) (num:nums) =
          dCaseE (DVarE equalsName `DAppE` DVarE n `DAppE` DLitE (IntegerL num))
            [ DMatch (DConP trueName  [] []) (DConE name)
            , DMatch (DConP falseName [] []) (to_enum_rhs rest nums) ]
        to_enum_rhs _ _ = error "Internal error: exhausted infinite list in to_enum_rhs"
  
        from_enum = UFunction (zipWith (\i con -> DClause [DConP (extractName con) [] []]
                                                          (DLitE (IntegerL i)))
                                       [0..] cons)
    return (InstDecl { id_cxt     = fromMaybe [] mb_ctxt
                     , id_name    = enumName
                     , id_arg_tys = [ty]
                     , id_sigs    = mempty
                     , id_meths   = [ (toEnumName, to_enum)
                                    , (fromEnumName, from_enum) ] })
  