-----------------------------------------------------------------------------
-- |
-- 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) ] }