{-# LANGUAGE ExplicitNamespaces #-}

-----------------------------------------------------------------------------
-- |
-- 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 everything you need to derive your own singletons via
-- Template Haskell.
--
-- TURN ON @-XScopedTypeVariables@ IN YOUR MODULE IF YOU WANT THIS TO WORK.
--
----------------------------------------------------------------------------

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,
  singEqInstancesOnly, singEqInstanceOnly,
  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
  SBool(..), STuple0(..), STuple2(..), STuple3(..), STuple4(..),
  STuple5(..), STuple6(..), STuple7(..), SOrdering(..),
  module Data.Singletons,

  -- * Auxiliary definitions
  -- | These definitions might be mentioned in code generated by Template Haskell,
  -- so they must be in scope.

  PEq(..), If, sIf, type (&&), (%&&), SEq(..),
  POrd(..), SOrd(..), ThenCmp, sThenCmp,
  SDecide(..), (:~:)(..), Void, Refuted, Decision(..),
  PBounded(..), SBounded(..),
  PEnum(FromEnum, ToEnum), SEnum(sFromEnum, sToEnum),
  PShow(..), SShow(..),
  ShowString, sShowString, ShowParen, sShowParen, ShowSpace, sShowSpace,
  ShowChar, sShowChar, ShowCommaSpace, sShowCommaSpace,
  PFunctor(..), SFunctor(..),
  PFoldable(..), SFoldable(..), PMonoid(..), SMonoid(..),
  PTraversable(..), STraversable(..), PApplicative(..), SApplicative(..),
  type (.), (%.),
  SomeSing(..),

  Error, sError, ErrorSym0, ErrorSym1,
  Undefined, sUndefined, UndefinedSym0,
  TrueSym0, FalseSym0,
  type (==@#@$), type (==@#@$$), type (==@#@$$$),
  type (>@#@$),  type (>@#@$$),  type (>@#@$$$),
  LTSym0, EQSym0, GTSym0,
  Tuple0Sym0,
  Tuple2Sym0, Tuple2Sym1, Tuple2Sym2,
  Tuple3Sym0, Tuple3Sym1, Tuple3Sym2, Tuple3Sym3,
  Tuple4Sym0, Tuple4Sym1, Tuple4Sym2, Tuple4Sym3, Tuple4Sym4,
  Tuple5Sym0, Tuple5Sym1, Tuple5Sym2, Tuple5Sym3, Tuple5Sym4, Tuple5Sym5,
  Tuple6Sym0, Tuple6Sym1, Tuple6Sym2, Tuple6Sym3, Tuple6Sym4, Tuple6Sym5, Tuple6Sym6,
  Tuple7Sym0, Tuple7Sym1, Tuple7Sym2, Tuple7Sym3, Tuple7Sym4, Tuple7Sym5, Tuple7Sym6, Tuple7Sym7,
  CompareSym0, CompareSym1, CompareSym2,
  ThenCmpSym0, ThenCmpSym1, ThenCmpSym2,
  FoldlSym0, FoldlSym1, FoldlSym2, FoldlSym3,
  MinBoundSym0, MaxBoundSym0,
  ShowsPrecSym0, ShowsPrecSym1, ShowsPrecSym2, ShowsPrecSym3,
  ShowStringSym0, ShowStringSym1, ShowStringSym2,
  ShowParenSym0, ShowParenSym1, ShowParenSym2,
  ShowSpaceSym0, ShowSpaceSym1,
  ShowCharSym0, ShowCharSym1, ShowCharSym2,
  ShowCommaSpaceSym0, ShowCommaSpaceSym1,
  FmapSym0, FmapSym1, FmapSym2,
  type (<$@#@$),  type (<$@#@$$),  type (<$@#@$$$),
  FoldMapSym0, FoldMapSym1, FoldMapSym2,
  MemptySym0,
  MappendSym0, MappendSym1, MappendSym2,
  FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3,
  TraverseSym0, TraverseSym1, TraverseSym2,
  PureSym0, PureSym1,
  type (<*>@#@$), type (<*>@#@$$), type (<*>@#@$$$),
  LiftA2Sym0, LiftA2Sym1, LiftA2Sym2, LiftA2Sym3,
  type (.@#@$), type (.@#@$$), type (.@#@$$$), type (.@#@$$$$),
  NilSym0, (:@#@$), (:@#@$$), (:@#@$$$),

  SuppressUnusedWarnings(..)

 ) where

import Data.Singletons
import Data.Singletons.Single
import Data.Singletons.Promote
import Data.Singletons.Prelude.Applicative
import Data.Singletons.Prelude.Base
  hiding (Foldr, FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3, sFoldr)
import Data.Singletons.Prelude.Instances
  hiding (Foldl, FoldlSym0, FoldlSym1, FoldlSym2, FoldlSym3, sFoldl)
import Data.Singletons.Prelude.Bool
import Data.Singletons.Prelude.Enum
import Data.Singletons.Prelude.Eq
import Data.Singletons.Prelude.Foldable
import Data.Singletons.Prelude.Functor hiding (Void)
import Data.Singletons.Prelude.Monoid
import Data.Singletons.Prelude.Ord
import Data.Singletons.Prelude.Show
import Data.Singletons.Prelude.Traversable
import Data.Singletons.Decide
import Data.Singletons.TH.Options
import Data.Singletons.TypeLits
import Data.Singletons.SuppressUnusedWarnings
import Language.Haskell.TH.Desugar

import Language.Haskell.TH
import Data.Singletons.Util
import Control.Arrow ( first )

-- | 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 :: 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
_ [DTyVarBndr]
_ 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 (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 (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 :: 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
_ [DTyVarBndr]
_ 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 (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 (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 (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 :: [(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 (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)
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 -> [DPat] -> DPat
DConP Name
name (Int -> DPat -> [DPat]
forall a. Int -> a -> [a]
replicate Int
num_fields DPat
DWildP)