    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Data.Singletons.Deriving.Bounded
    -- Copyright   :  (C) 2015 Richard Eisenberg
    -- License     :  BSD-style (see LICENSE)
    -- Maintainer  :  Ryan Scott
    -- Stability   :  experimental
    -- Portability :  non-portable
    --
    -- Implements deriving of Bounded instances
    --
    ----------------------------------------------------------------------------

    module Data.Singletons.Deriving.Bounded where

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

    -- monadic only for failure and parallelism with other functions
    -- that make instances
    mkBoundedInstance :: DsMonad q => DerivDesc q
    mkBoundedInstance :: DerivDesc q
    mkBoundedInstance mb_ctxt :: Maybe DCxt
    mb_ctxt ty :: DType
    ty (DataDecl _ _ cons :: [DCon]
    cons) = do
      -- We can derive instance of Bounded if datatype is an enumeration (all
      -- constructors must be nullary) or has only one constructor. See Section 11
      -- of Haskell 2010 Language Report.
      -- Note that order of conditions below is important.
      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 -> Bool
    not (Bool -> Bool) -> (DConFields -> Bool) -> DConFields -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DCxt -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (DCxt -> Bool) -> (DConFields -> DCxt) -> DConFields -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DConFields -> DCxt
    tysOfConFields (DConFields -> Bool) -> DConFields -> Bool
    forall a b. (a -> b) -> a -> b
    $ DConFields
    f) [DCon]
    cons
                Bool -> Bool -> Bool
    && (Bool -> Bool
    not (Bool -> Bool) -> ([DCon] -> Bool) -> [DCon] -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [DCon] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null ([DCon] -> Bool) -> ([DCon] -> [DCon]) -> [DCon] -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [DCon] -> [DCon]
    forall a. [a] -> [a]
    tail ([DCon] -> Bool) -> [DCon] -> Bool
    forall a b. (a -> b) -> a -> b
    $ [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 Bounded 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]
    ++ ".")
      -- at this point we know that either we have a datatype that has only one
      -- constructor or a datatype where each constructor is nullary
      let (DCon _ _ minName :: Name
    minName fields :: DConFields
    fields _) = [DCon] -> DCon
    forall a. [a] -> a
    head [DCon]
    cons
          (DCon _ _ maxName :: Name
    maxName _ _)      = [DCon] -> DCon
    forall a. [a] -> a
    last [DCon]
    cons
          fieldsCount :: Int
    fieldsCount   = DCxt -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length (DCxt -> Int) -> DCxt -> Int
    forall a b. (a -> b) -> a -> b
    $ DConFields -> DCxt
    tysOfConFields DConFields
    fields
          (minRHS :: DExp
    minRHS, maxRHS :: DExp
    maxRHS) = case Int
    fieldsCount of
            0 -> (Name -> DExp
    DConE Name
    minName, Name -> DExp
    DConE Name
    maxName)
            _ ->
              let minEqnRHS :: DExp
    minEqnRHS = DExp -> [DExp] -> DExp
    foldExp (Name -> DExp
    DConE Name
    minName)
                                      (Int -> DExp -> [DExp]
    forall a. Int -> a -> [a]
    replicate Int
    fieldsCount (Name -> DExp
    DVarE Name
    minBoundName))
                  maxEqnRHS :: DExp
    maxEqnRHS = DExp -> [DExp] -> DExp
    foldExp (Name -> DExp
    DConE Name
    maxName)
                                      (Int -> DExp -> [DExp]
    forall a. Int -> a -> [a]
    replicate Int
    fieldsCount (Name -> DExp
    DVarE Name
    maxBoundName))
              in (DExp
    minEqnRHS, DExp
    maxEqnRHS)

          mk_rhs :: DExp -> LetDecRHS Unannotated
    mk_rhs rhs :: DExp
    rhs = [DClause] -> LetDecRHS Unannotated
    UFunction [[DPat] -> DExp -> DClause
    DClause [] DExp
    rhs]
      DCxt
    constraints <- Maybe DCxt -> DType -> DType -> [DCon] -> q DCxt
    forall (q :: * -> *).
    DsMonad q =>
    Maybe DCxt -> DType -> DType -> [DCon] -> q DCxt
    inferConstraintsDef Maybe DCxt
    mb_ctxt (Name -> DType
    DConT Name
    boundedName) DType
    ty [DCon]
    cons
      InstDecl Unannotated -> q (InstDecl Unannotated)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (InstDecl Unannotated -> q (InstDecl Unannotated))
    -> InstDecl Unannotated -> q (InstDecl Unannotated)
    forall a b. (a -> b) -> a -> b
    $ InstDecl :: forall (ann :: AnnotationFlag).
    DCxt
    -> Name
    -> DCxt
    -> OMap Name DType
    -> [(Name, LetDecRHS ann)]
    -> InstDecl ann
    InstDecl { id_cxt :: DCxt
    id_cxt = DCxt
    constraints
                        , id_name :: Name
    id_name = Name
    boundedName
                        , 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
    minBoundName, DExp -> LetDecRHS Unannotated
    mk_rhs DExp
    minRHS)
                                     , (Name
    maxBoundName, DExp -> LetDecRHS Unannotated
    mk_rhs DExp
    maxRHS) ] }