-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Singletons.TH.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.TH.Deriving.Bounded where

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

-- monadic only for failure and parallelism with other functions
-- that make instances
mkBoundedInstance :: DsMonad q => DerivDesc q
mkBoundedInstance :: forall (q :: * -> *). DsMonad q => DerivDesc q
mkBoundedInstance Maybe DCxt
mb_ctxt DType
ty (DataDecl DataFlavor
_ Name
_ [DTyVarBndrVis]
_ [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.
  let illegal_bounded_inst :: Bool
illegal_bounded_inst =
        case [DCon]
cons of
          [] -> Bool
True
          DCon
_:[DCon]
cons' ->
            (DCon -> Bool) -> [DCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(DCon [DTyVarBndrSpec]
_ DCxt
_ Name
_ DConFields
f DType
_) -> Bool -> Bool
not (Bool -> Bool) -> (DConFields -> Bool) -> DConFields -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DCxt -> Bool
forall a. [a] -> 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 ([DCon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DCon]
cons')
  Bool -> q () -> q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
illegal_bounded_inst (q () -> q ()) -> q () -> q ()
forall a b. (a -> b) -> a -> b
$
       String -> q ()
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"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]
++ String
".")
  -- 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 internal_err :: q a
internal_err = String -> q a
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Internal error (mkBoundedInstance): non-empty list of constructors"
  DCon _ _ minName fields _ <-
    case [DCon]
cons of
      (DCon
c:[DCon]
_) -> DCon -> q DCon
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DCon
c
      [] -> q DCon
forall {a}. q a
internal_err
  let (_, DCon _ _ maxName _ _) = snocView cons
      fieldsCount   = DCxt -> Int
forall a. [a] -> 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, maxRHS) = case fieldsCount of
        Int
0 -> (Name -> DExp
DConE Name
minName, Name -> DExp
DConE Name
maxName)
        Int
_ ->
          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
rhs = [DClause] -> LetDecRHS Unannotated
UFunction [[DPat] -> DExp -> DClause
DClause [] DExp
rhs]
  constraints <- inferConstraintsDef mb_ctxt (DConT boundedName) ty cons
  return $ InstDecl { id_cxt = constraints
                    , id_name = boundedName
                    , id_arg_tys = [ty]
                    , id_sigs  = mempty
                    , id_meths = [ (minBoundName, mk_rhs minRHS)
                                 , (maxBoundName, mk_rhs maxRHS) ] }