TH.hs

-----------------------------------------------------------------------------
-- |
-- 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 tyName expq bodyq = do
  dinfo <- dsReify tyName
  case dinfo of
    Just (DTyConI (DDataD _ _ _ _ _ ctors _) _) ->
      expToTH <$> buildCases (map extractNameArgs ctors) expq bodyq
    Just _ ->
      fail $ "Using <<cases>> with something other than a type constructor: "
              ++ (show tyName)
    _ -> fail $ "Cannot find " ++ show 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 tyName expq bodyq = do
  opts  <- getOptions
  dinfo <- dsReify tyName
  case dinfo of
    Just (DTyConI (DDataD _ _ _ _ _ ctors _) _) ->
      let ctor_stuff = map (first (singledDataConName opts) . extractNameArgs) ctors in
      expToTH <$> buildCases ctor_stuff expq bodyq
    Just _ ->
      fail $ "Using <<cases>> with something other than a type constructor: "
              ++ (show tyName)
    _ -> fail $ "Cannot find " ++ show tyName

buildCases :: DsMonad m
           => [(Name, Int)]
           -> m Exp  -- scrutinee
           -> m Exp  -- body
           -> m DExp
buildCases ctor_infos expq bodyq =
  dCaseE <$> (dsExp =<< expq) <*>
             mapM (\con -> DMatch (conToPat con) <$> (dsExp =<< bodyq)) ctor_infos
  where
    conToPat :: (Name, Int) -> DPat
    conToPat (name, num_fields) =
      DConP name [] (replicate num_fields DWildP)