-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Singletons.TH
-- Copyright   :  (C) 2013 Richard Eisenberg
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  Ryan Scott
-- Stability   :  experimental
-- Portability :  non-portable
--
-- This module contains basic functionality for deriving your own singletons
-- via Template Haskell. Note that this module does not define any singled
-- definitions on its own. For a version of this module that comes pre-equipped
-- with several singled definitions based on the "Prelude", see
-- @Data.Singletons.Base.TH@ from the @singletons-base@ library.
--
----------------------------------------------------------------------------

module Data.Singletons.TH (
  -- * Primary Template Haskell generation functions
  singletons, singletonsOnly, genSingletons,
  promote, promoteOnly, genDefunSymbols, genPromotions,

  -- ** Functions to generate equality instances
  promoteEqInstances, promoteEqInstance,
  singEqInstances, singEqInstance,
  singDecideInstances, singDecideInstance,

  -- ** Functions to generate 'Ord' instances
  promoteOrdInstances, promoteOrdInstance,
  singOrdInstances, singOrdInstance,

  -- ** Functions to generate 'Bounded' instances
  promoteBoundedInstances, promoteBoundedInstance,
  singBoundedInstances, singBoundedInstance,

  -- ** Functions to generate 'Enum' instances
  promoteEnumInstances, promoteEnumInstance,
  singEnumInstances, singEnumInstance,

  -- ** Functions to generate 'Show' instances
  promoteShowInstances, promoteShowInstance,
  singShowInstances, singShowInstance,
  showSingInstances, showSingInstance,

  -- ** Utility functions
  singITyConInstances, singITyConInstance,
  cases, sCases,

  -- * Basic singleton definitions
  module Data.Singletons,

  -- * Auxiliary definitions
  SDecide(..), (:~:)(..), Void, Refuted, Decision(..),

  SuppressUnusedWarnings(..)

 ) where

import Control.Arrow ( first )
import Data.Singletons
import Data.Singletons.Decide
import Data.Singletons.TH.Options
import Data.Singletons.TH.Promote
import Data.Singletons.TH.Single
import Data.Singletons.TH.SuppressUnusedWarnings
import Data.Singletons.TH.Util
import Language.Haskell.TH
import Language.Haskell.TH.Desugar

-- | The function 'cases' generates a case expression where each right-hand side
-- is identical. This may be useful if the type-checker requires knowledge of which
-- constructor is used to satisfy equality or type-class constraints, but where
-- each constructor is treated the same.
cases :: DsMonad q
      => Name        -- ^ The head of the type of the scrutinee. (Like @''Maybe@ or @''Bool@.)
      -> q Exp       -- ^ The scrutinee, in a Template Haskell quote
      -> q Exp       -- ^ The body, in a Template Haskell quote
      -> q Exp
cases :: forall (q :: * -> *). DsMonad q => Name -> q Exp -> q Exp -> q Exp
cases Name
tyName q Exp
expq q Exp
bodyq = do
  Maybe DInfo
dinfo <- Name -> q (Maybe DInfo)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReify Name
tyName
  case Maybe DInfo
dinfo of
    Just (DTyConI (DDataD NewOrData
_ DCxt
_ Name
_ [DTyVarBndrUnit]
_ Maybe DKind
_ [DCon]
ctors [DDerivClause]
_) Maybe [DDec]
_) ->
      DExp -> Exp
expToTH (DExp -> Exp) -> q DExp -> q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Int)] -> q Exp -> q Exp -> q DExp
forall (m :: * -> *).
DsMonad m =>
[(Name, Int)] -> m Exp -> m Exp -> m DExp
buildCases ((DCon -> (Name, Int)) -> [DCon] -> [(Name, Int)]
forall a b. (a -> b) -> [a] -> [b]
map DCon -> (Name, Int)
extractNameArgs [DCon]
ctors) q Exp
expq q Exp
bodyq
    Just DInfo
_ ->
      String -> q Exp
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q Exp) -> String -> q Exp
forall a b. (a -> b) -> a -> b
$ String
"Using <<cases>> with something other than a type constructor: "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Name -> String
forall a. Show a => a -> String
show Name
tyName)
    Maybe DInfo
_ -> String -> q Exp
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q Exp) -> String -> q Exp
forall a b. (a -> b) -> a -> b
$ String
"Cannot find " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
tyName

-- | The function 'sCases' generates a case expression where each right-hand side
-- is identical. This may be useful if the type-checker requires knowledge of which
-- constructor is used to satisfy equality or type-class constraints, but where
-- each constructor is treated the same. For 'sCases', unlike 'cases', the
-- scrutinee is a singleton. But make sure to pass in the name of the /original/
-- datatype, preferring @''Maybe@ over @''SMaybe@.
sCases :: OptionsMonad q
       => Name        -- ^ The head of the type the scrutinee's type is based on.
                      -- (Like @''Maybe@ or @''Bool@.)
       -> q Exp       -- ^ The scrutinee, in a Template Haskell quote
       -> q Exp       -- ^ The body, in a Template Haskell quote
       -> q Exp
sCases :: forall (q :: * -> *).
OptionsMonad q =>
Name -> q Exp -> q Exp -> q Exp
sCases Name
tyName q Exp
expq q Exp
bodyq = do
  Options
opts  <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
  Maybe DInfo
dinfo <- Name -> q (Maybe DInfo)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReify Name
tyName
  case Maybe DInfo
dinfo of
    Just (DTyConI (DDataD NewOrData
_ DCxt
_ Name
_ [DTyVarBndrUnit]
_ Maybe DKind
_ [DCon]
ctors [DDerivClause]
_) Maybe [DDec]
_) ->
      let ctor_stuff :: [(Name, Int)]
ctor_stuff = (DCon -> (Name, Int)) -> [DCon] -> [(Name, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> Name) -> (Name, Int) -> (Name, Int)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Options -> Name -> Name
singledDataConName Options
opts) ((Name, Int) -> (Name, Int))
-> (DCon -> (Name, Int)) -> DCon -> (Name, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DCon -> (Name, Int)
extractNameArgs) [DCon]
ctors in
      DExp -> Exp
expToTH (DExp -> Exp) -> q DExp -> q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Int)] -> q Exp -> q Exp -> q DExp
forall (m :: * -> *).
DsMonad m =>
[(Name, Int)] -> m Exp -> m Exp -> m DExp
buildCases [(Name, Int)]
ctor_stuff q Exp
expq q Exp
bodyq
    Just DInfo
_ ->
      String -> q Exp
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q Exp) -> String -> q Exp
forall a b. (a -> b) -> a -> b
$ String
"Using <<cases>> with something other than a type constructor: "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Name -> String
forall a. Show a => a -> String
show Name
tyName)
    Maybe DInfo
_ -> String -> q Exp
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q Exp) -> String -> q Exp
forall a b. (a -> b) -> a -> b
$ String
"Cannot find " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
tyName

buildCases :: DsMonad m
           => [(Name, Int)]
           -> m Exp  -- scrutinee
           -> m Exp  -- body
           -> m DExp
buildCases :: forall (m :: * -> *).
DsMonad m =>
[(Name, Int)] -> m Exp -> m Exp -> m DExp
buildCases [(Name, Int)]
ctor_infos m Exp
expq m Exp
bodyq =
  DExp -> [DMatch] -> DExp
DCaseE (DExp -> [DMatch] -> DExp) -> m DExp -> m ([DMatch] -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> m DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp (Exp -> m DExp) -> m Exp -> m DExp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Exp
expq) m ([DMatch] -> DExp) -> m [DMatch] -> m DExp
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
             ((Name, Int) -> m DMatch) -> [(Name, Int)] -> m [DMatch]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Name, Int)
con -> DPat -> DExp -> DMatch
DMatch ((Name, Int) -> DPat
conToPat (Name, Int)
con) (DExp -> DMatch) -> m DExp -> m DMatch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> m DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp (Exp -> m DExp) -> m Exp -> m DExp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Exp
bodyq)) [(Name, Int)]
ctor_infos
  where
    conToPat :: (Name, Int) -> DPat
    conToPat :: (Name, Int) -> DPat
conToPat (Name
name, Int
num_fields) =
      Name -> DCxt -> [DPat] -> DPat
DConP Name
name [] (Int -> DPat -> [DPat]
forall a. Int -> a -> [a]
replicate Int
num_fields DPat
DWildP)