-----------------------------------------------------------------------------

-- |

-- 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.

--

-- Here is a simple example to illustrate where 'cases' can be useful. Suppose

-- you use @singletons-th@ to single this code:

--

-- @

-- $('singletons' [d|

--   foo :: Bool -> ()

--   foo True = ()

--   foo False = ()

--   |])

-- @

--

-- And that you want to write a function of this type:

--

-- @

-- bar :: SBool b -> STuple0 (Foo b)

-- @

--

-- How would you do this? You might be tempted to write the following:

--

-- @

-- bar _ = STuple0

-- @

--

-- However, this won't typecheck, as Foo b won't reduce to @'()@ unless GHC

-- knows @b@ is either 'True' or 'False'. In order to convince GHC of this, you

-- must explicitly match on each of the data constructors of @SBool@:

--

-- @

-- bar :: SBool b -> STuple0 (Foo b)

-- bar b = case b of

--   STrue  -> STuple0

--   SFalse -> STuple0

-- @

--

-- This is doable, but it is somewhat tedious. After all, the right-hand side

-- of each case alternative is exactly the same! This only becomes more tedious

-- when you deal with data types with lots of lots of data constructors. For

-- this reason, @singletons-th@ offers the 'cases' function to generate this

-- boilerplate code for you. The following is equivalent to the implementation

-- of @bar@ above:

--

-- @

-- bar :: SBool b -> STuple0 (Foo b)

-- bar b = $(cases ''SBool [| b |] [| STuple0 |])

-- @

cases :: DsMonad q
      => Name        -- ^ The head of the type of the scrutinee. (e.g., @''SBool@)

      -> 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 DataFlavor
_ 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@. In other words, @sCases ''Maybe@ is equivalent to

-- @'cases' ''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 DataFlavor
_ 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)