    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Data.Singletons.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.Deriving.Enum ( mkEnumInstance ) where

    import Language.Haskell.TH.Syntax
    import Language.Haskell.TH.Ppr
    import Language.Haskell.TH.Desugar
    import Data.Singletons.Deriving.Util
    import Data.Singletons.Syntax
    import Data.Singletons.Util
    import Data.Singletons.Names
    import Control.Monad
    import Data.Maybe

    -- monadic for failure only
    mkEnumInstance :: DsMonad q => DerivDesc q
    mkEnumInstance :: DerivDesc q
    mkEnumInstance mb_ctxt :: Maybe DCxt
    mb_ctxt ty :: DType
    ty (DataDecl data_name :: Name
    data_name tvbs :: [DTyVarBndr]
    tvbs cons :: [DCon]
    cons) = do
      let data_ty :: DType
    data_ty = DType -> [DTyVarBndr] -> DType
    foldTypeTvbs (Name -> DType
    DConT Name
    data_name) [DTyVarBndr]
    tvbs
      Bool
    non_vanilla <- DType -> [DCon] -> q Bool
    forall (q :: * -> *). DsMonad q => DType -> [DCon] -> q Bool
    isNonVanillaDataType DType
    data_ty [DCon]
    cons
      Bool -> q () -> q ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when ([DCon] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [DCon]
    cons Bool -> Bool -> Bool
    ||
            (DCon -> Bool) -> [DCon] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (\(DCon _ _ _ f :: DConFields
    f _) ->
                  Bool
    non_vanilla Bool -> Bool -> Bool
    || Bool -> Bool
    not (DCxt -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (DCxt -> Bool) -> DCxt -> Bool
    forall a b. (a -> b) -> a -> b
    $ DConFields -> DCxt
    tysOfConFields DConFields
    f)) [DCon]
    cons) (q () -> q ()) -> q () -> q ()
    forall a b. (a -> b) -> a -> b
    $
        String -> q ()
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail ("Can't derive Enum instance for " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Ppr a => a -> String
    pprint (DType -> Type
    typeToTH DType
    ty) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ".")
      Name
    n <- String -> q Name
    forall (m :: * -> *). Quasi m => String -> m Name
    qNewName "n"
      let to_enum :: LetDecRHS Unannotated
    to_enum = [DClause] -> LetDecRHS Unannotated
    UFunction [[DPat] -> DExp -> DClause
    DClause [Name -> DPat
    DVarP Name
    n] ([DCon] -> [Integer] -> DExp
    to_enum_rhs [DCon]
    cons [0..])]
          to_enum_rhs :: [DCon] -> [Integer] -> DExp
    to_enum_rhs [] _ = Name -> DExp
    DVarE Name
    errorName DExp -> DExp -> DExp
    `DAppE` Lit -> DExp
    DLitE (String -> Lit
    StringL "toEnum: bad argument")
          to_enum_rhs (DCon _ _ name :: Name
    name _ _ : rest :: [DCon]
    rest) (num :: Integer
    num:nums :: [Integer]
    nums) =
            DExp -> [DMatch] -> DExp
    DCaseE (Name -> DExp
    DVarE Name
    equalsName DExp -> DExp -> DExp
    `DAppE` Name -> DExp
    DVarE Name
    n DExp -> DExp -> DExp
    `DAppE` Lit -> DExp
    DLitE (Integer -> Lit
    IntegerL Integer
    num))
              [ DPat -> DExp -> DMatch
    DMatch (Name -> [DPat] -> DPat
    DConP Name
    trueName []) (Name -> DExp
    DConE Name
    name)
              , DPat -> DExp -> DMatch
    DMatch (Name -> [DPat] -> DPat
    DConP Name
    falseName []) ([DCon] -> [Integer] -> DExp
    to_enum_rhs [DCon]
    rest [Integer]
    nums) ]
          to_enum_rhs _ _ = String -> DExp
    forall a. HasCallStack => String -> a
    error "Internal error: exhausted infinite list in to_enum_rhs"

          from_enum :: LetDecRHS Unannotated
    from_enum = [DClause] -> LetDecRHS Unannotated
    UFunction ((Integer -> DCon -> DClause) -> [Integer] -> [DCon] -> [DClause]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\i :: Integer
    i con :: DCon
    con -> [DPat] -> DExp -> DClause
    DClause [Name -> [DPat] -> DPat
    DConP (DCon -> Name
    extractName DCon
    con) []]
                                                            (Lit -> DExp
    DLitE (Integer -> Lit
    IntegerL Integer
    i)))
                                         [0..] [DCon]
    cons)
      InstDecl Unannotated -> q (InstDecl Unannotated)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (InstDecl :: forall (ann :: AnnotationFlag).
    DCxt
    -> Name
    -> DCxt
    -> OMap Name DType
    -> [(Name, LetDecRHS ann)]
    -> InstDecl ann
    InstDecl { id_cxt :: DCxt
    id_cxt     = DCxt -> Maybe DCxt -> DCxt
    forall a. a -> Maybe a -> a
    fromMaybe [] Maybe DCxt
    mb_ctxt
                       , id_name :: Name
    id_name    = Name
    singletonsEnumName
                          -- need to use singletons's Enum class to get the types
                          -- to use Nat instead of Int

                       , id_arg_tys :: DCxt
    id_arg_tys = [DType
    ty]
                       , id_sigs :: OMap Name DType
    id_sigs    = OMap Name DType
    forall a. Monoid a => a
    mempty
                       , id_meths :: [(Name, LetDecRHS Unannotated)]
    id_meths   = [ (Name
    singletonsToEnumName, LetDecRHS Unannotated
    to_enum)
                                      , (Name
    singletonsFromEnumName, LetDecRHS Unannotated
    from_enum) ] })