-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Singletons.Partition
-- Copyright   :  (C) 2015 Richard Eisenberg
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  Ryan Scott
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Partitions a list of declarations into its bits
--
----------------------------------------------------------------------------

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

module Data.Singletons.Partition where

import Prelude hiding ( exp )
import Data.Singletons.Syntax
import Data.Singletons.Deriving.Ord
import Data.Singletons.Deriving.Bounded
import Data.Singletons.Deriving.Enum
import Data.Singletons.Deriving.Foldable
import Data.Singletons.Deriving.Functor
import Data.Singletons.Deriving.Show
import Data.Singletons.Deriving.Traversable
import Data.Singletons.Deriving.Util
import Data.Singletons.Names
import Data.Singletons.TH.Options
import Language.Haskell.TH.Syntax hiding (showName)
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.Desugar
import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap
import Language.Haskell.TH.Desugar.OMap.Strict (OMap)
import Data.Singletons.Util

import Control.Monad
import Data.Bifunctor (bimap)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe

data PartitionedDecs =
  PDecs { PartitionedDecs -> [DLetDec]
pd_let_decs :: [DLetDec]
        , PartitionedDecs -> [UClassDecl]
pd_class_decs :: [UClassDecl]
        , PartitionedDecs -> [UInstDecl]
pd_instance_decs :: [UInstDecl]
        , PartitionedDecs -> [DataDecl]
pd_data_decs :: [DataDecl]
        , PartitionedDecs -> [TySynDecl]
pd_ty_syn_decs :: [TySynDecl]
        , PartitionedDecs -> [OpenTypeFamilyDecl]
pd_open_type_family_decs :: [OpenTypeFamilyDecl]
        , PartitionedDecs -> [ClosedTypeFamilyDecl]
pd_closed_type_family_decs :: [ClosedTypeFamilyDecl]
        , PartitionedDecs -> [DerivedEqDecl]
pd_derived_eq_decs :: [DerivedEqDecl]
        , PartitionedDecs -> [DerivedShowDecl]
pd_derived_show_decs :: [DerivedShowDecl]
        }

instance Semigroup PartitionedDecs where
  PDecs [DLetDec]
a1 [UClassDecl]
b1 [UInstDecl]
c1 [DataDecl]
d1 [TySynDecl]
e1 [OpenTypeFamilyDecl]
f1 [ClosedTypeFamilyDecl]
g1 [DerivedEqDecl]
h1 [DerivedShowDecl]
i1 <> :: PartitionedDecs -> PartitionedDecs -> PartitionedDecs
<> PDecs [DLetDec]
a2 [UClassDecl]
b2 [UInstDecl]
c2 [DataDecl]
d2 [TySynDecl]
e2 [OpenTypeFamilyDecl]
f2 [ClosedTypeFamilyDecl]
g2 [DerivedEqDecl]
h2 [DerivedShowDecl]
i2 =
    [DLetDec]
-> [UClassDecl]
-> [UInstDecl]
-> [DataDecl]
-> [TySynDecl]
-> [OpenTypeFamilyDecl]
-> [ClosedTypeFamilyDecl]
-> [DerivedEqDecl]
-> [DerivedShowDecl]
-> PartitionedDecs
PDecs ([DLetDec]
a1 [DLetDec] -> [DLetDec] -> [DLetDec]
forall a. Semigroup a => a -> a -> a
<> [DLetDec]
a2) ([UClassDecl]
b1 [UClassDecl] -> [UClassDecl] -> [UClassDecl]
forall a. Semigroup a => a -> a -> a
<> [UClassDecl]
b2) ([UInstDecl]
c1 [UInstDecl] -> [UInstDecl] -> [UInstDecl]
forall a. Semigroup a => a -> a -> a
<> [UInstDecl]
c2) ([DataDecl]
d1 [DataDecl] -> [DataDecl] -> [DataDecl]
forall a. Semigroup a => a -> a -> a
<> [DataDecl]
d2) ([TySynDecl]
e1 [TySynDecl] -> [TySynDecl] -> [TySynDecl]
forall a. Semigroup a => a -> a -> a
<> [TySynDecl]
e2)
          ([OpenTypeFamilyDecl]
f1 [OpenTypeFamilyDecl]
-> [OpenTypeFamilyDecl] -> [OpenTypeFamilyDecl]
forall a. Semigroup a => a -> a -> a
<> [OpenTypeFamilyDecl]
f2) ([ClosedTypeFamilyDecl]
g1 [ClosedTypeFamilyDecl]
-> [ClosedTypeFamilyDecl] -> [ClosedTypeFamilyDecl]
forall a. Semigroup a => a -> a -> a
<> [ClosedTypeFamilyDecl]
g2) ([DerivedEqDecl]
h1 [DerivedEqDecl] -> [DerivedEqDecl] -> [DerivedEqDecl]
forall a. Semigroup a => a -> a -> a
<> [DerivedEqDecl]
h2) ([DerivedShowDecl]
i1 [DerivedShowDecl] -> [DerivedShowDecl] -> [DerivedShowDecl]
forall a. Semigroup a => a -> a -> a
<> [DerivedShowDecl]
i2)

instance Monoid PartitionedDecs where
  mempty :: PartitionedDecs
mempty = [DLetDec]
-> [UClassDecl]
-> [UInstDecl]
-> [DataDecl]
-> [TySynDecl]
-> [OpenTypeFamilyDecl]
-> [ClosedTypeFamilyDecl]
-> [DerivedEqDecl]
-> [DerivedShowDecl]
-> PartitionedDecs
PDecs [DLetDec]
forall a. Monoid a => a
mempty [UClassDecl]
forall a. Monoid a => a
mempty [UInstDecl]
forall a. Monoid a => a
mempty [DataDecl]
forall a. Monoid a => a
mempty [TySynDecl]
forall a. Monoid a => a
mempty
                 [OpenTypeFamilyDecl]
forall a. Monoid a => a
mempty [ClosedTypeFamilyDecl]
forall a. Monoid a => a
mempty [DerivedEqDecl]
forall a. Monoid a => a
mempty [DerivedShowDecl]
forall a. Monoid a => a
mempty

-- | Split up a @[DDec]@ into its pieces, extracting 'Ord' instances
-- from deriving clauses
partitionDecs :: OptionsMonad m => [DDec] -> m PartitionedDecs
partitionDecs :: [DDec] -> m PartitionedDecs
partitionDecs = (DDec -> m PartitionedDecs) -> [DDec] -> m PartitionedDecs
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM DDec -> m PartitionedDecs
forall (m :: * -> *). OptionsMonad m => DDec -> m PartitionedDecs
partitionDec

partitionDec :: OptionsMonad m => DDec -> m PartitionedDecs
partitionDec :: DDec -> m PartitionedDecs
partitionDec (DLetDec (DPragmaD {})) = PartitionedDecs -> m PartitionedDecs
forall (m :: * -> *) a. Monad m => a -> m a
return PartitionedDecs
forall a. Monoid a => a
mempty
partitionDec (DLetDec DLetDec
letdec) = PartitionedDecs -> m PartitionedDecs
forall (m :: * -> *) a. Monad m => a -> m a
return (PartitionedDecs -> m PartitionedDecs)
-> PartitionedDecs -> m PartitionedDecs
forall a b. (a -> b) -> a -> b
$ PartitionedDecs
forall a. Monoid a => a
mempty { pd_let_decs :: [DLetDec]
pd_let_decs = [DLetDec
letdec] }

partitionDec (DDataD NewOrData
_nd DCxt
_cxt Name
name [DTyVarBndr]
tvbs Maybe DKind
mk [DCon]
cons [DDerivClause]
derivings) = do
  [DTyVarBndr]
all_tvbs <- [DTyVarBndr] -> Maybe DKind -> m [DTyVarBndr]
forall (q :: * -> *).
DsMonad q =>
[DTyVarBndr] -> Maybe DKind -> q [DTyVarBndr]
buildDataDTvbs [DTyVarBndr]
tvbs Maybe DKind
mk
  let data_decl :: DataDecl
data_decl   = Name -> [DTyVarBndr] -> [DCon] -> DataDecl
DataDecl Name
name [DTyVarBndr]
all_tvbs [DCon]
cons
      derived_dec :: PartitionedDecs
derived_dec = PartitionedDecs
forall a. Monoid a => a
mempty { pd_data_decs :: [DataDecl]
pd_data_decs = [DataDecl
data_decl] }
  [PartitionedDecs]
derived_decs
    <- ((Maybe DDerivStrategy, DKind) -> m PartitionedDecs)
-> [(Maybe DDerivStrategy, DKind)] -> m [PartitionedDecs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Maybe DDerivStrategy
strat, DKind
deriv_pred) ->
              let etad_tvbs :: [DTyVarBndr]
etad_tvbs
                    | (DConT Name
pred_name, [DTypeArg]
_) <- DKind -> (DKind, [DTypeArg])
unfoldDType DKind
deriv_pred
                    , Name -> Bool
isFunctorLikeClassName Name
pred_name
                      -- If deriving Functor, Foldable, or Traversable,
                      -- we need to use one less type variable than we normally do.
                    = Int -> [DTyVarBndr] -> [DTyVarBndr]
forall a. Int -> [a] -> [a]
take ([DTyVarBndr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DTyVarBndr]
all_tvbs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [DTyVarBndr]
all_tvbs
                    | Bool
otherwise
                    = [DTyVarBndr]
all_tvbs
                  ty :: DKind
ty = DKind -> [DTyVarBndr] -> DKind
foldTypeTvbs (Name -> DKind
DConT Name
name) [DTyVarBndr]
etad_tvbs
              in Maybe DDerivStrategy
-> DKind -> Maybe DCxt -> DKind -> DataDecl -> m PartitionedDecs
forall (m :: * -> *).
OptionsMonad m =>
Maybe DDerivStrategy
-> DKind -> Maybe DCxt -> DKind -> DataDecl -> m PartitionedDecs
partitionDeriving Maybe DDerivStrategy
strat DKind
deriv_pred Maybe DCxt
forall a. Maybe a
Nothing DKind
ty DataDecl
data_decl)
      ([(Maybe DDerivStrategy, DKind)] -> m [PartitionedDecs])
-> [(Maybe DDerivStrategy, DKind)] -> m [PartitionedDecs]
forall a b. (a -> b) -> a -> b
$ (DDerivClause -> [(Maybe DDerivStrategy, DKind)])
-> [DDerivClause] -> [(Maybe DDerivStrategy, DKind)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DDerivClause -> [(Maybe DDerivStrategy, DKind)]
flatten_clause [DDerivClause]
derivings
  PartitionedDecs -> m PartitionedDecs
forall (m :: * -> *) a. Monad m => a -> m a
return (PartitionedDecs -> m PartitionedDecs)
-> PartitionedDecs -> m PartitionedDecs
forall a b. (a -> b) -> a -> b
$ [PartitionedDecs] -> PartitionedDecs
forall a. Monoid a => [a] -> a
mconcat ([PartitionedDecs] -> PartitionedDecs)
-> [PartitionedDecs] -> PartitionedDecs
forall a b. (a -> b) -> a -> b
$ PartitionedDecs
derived_dec PartitionedDecs -> [PartitionedDecs] -> [PartitionedDecs]
forall a. a -> [a] -> [a]
: [PartitionedDecs]
derived_decs
  where
    flatten_clause :: DDerivClause -> [(Maybe DDerivStrategy, DPred)]
    flatten_clause :: DDerivClause -> [(Maybe DDerivStrategy, DKind)]
flatten_clause (DDerivClause Maybe DDerivStrategy
strat DCxt
preds) =
      (DKind -> (Maybe DDerivStrategy, DKind))
-> DCxt -> [(Maybe DDerivStrategy, DKind)]
forall a b. (a -> b) -> [a] -> [b]
map (\DKind
p -> (Maybe DDerivStrategy
strat, DKind
p)) DCxt
preds

partitionDec (DClassD DCxt
cxt Name
name [DTyVarBndr]
tvbs [FunDep]
fds [DDec]
decs) = do
  (ULetDecEnv
lde, [OpenTypeFamilyDecl]
otfs) <- (DDec -> m (ULetDecEnv, [OpenTypeFamilyDecl]))
-> [DDec] -> m (ULetDecEnv, [OpenTypeFamilyDecl])
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM DDec -> m (ULetDecEnv, [OpenTypeFamilyDecl])
forall (m :: * -> *).
MonadFail m =>
DDec -> m (ULetDecEnv, [OpenTypeFamilyDecl])
partitionClassDec [DDec]
decs
  PartitionedDecs -> m PartitionedDecs
forall (m :: * -> *) a. Monad m => a -> m a
return (PartitionedDecs -> m PartitionedDecs)
-> PartitionedDecs -> m PartitionedDecs
forall a b. (a -> b) -> a -> b
$ PartitionedDecs
forall a. Monoid a => a
mempty { pd_class_decs :: [UClassDecl]
pd_class_decs = [ClassDecl :: forall (ann :: AnnotationFlag).
DCxt
-> Name
-> [DTyVarBndr]
-> [FunDep]
-> LetDecEnv ann
-> [OpenTypeFamilyDecl]
-> ClassDecl ann
ClassDecl { cd_cxt :: DCxt
cd_cxt       = DCxt
cxt
                                               , cd_name :: Name
cd_name      = Name
name
                                               , cd_tvbs :: [DTyVarBndr]
cd_tvbs      = [DTyVarBndr]
tvbs
                                               , cd_fds :: [FunDep]
cd_fds       = [FunDep]
fds
                                               , cd_lde :: ULetDecEnv
cd_lde       = ULetDecEnv
lde
                                               , cd_atfs :: [OpenTypeFamilyDecl]
cd_atfs      = [OpenTypeFamilyDecl]
otfs}] }
partitionDec (DInstanceD Maybe Overlap
_ Maybe [DTyVarBndr]
_ DCxt
cxt DKind
ty [DDec]
decs) = do
  ([(Name, ULetDecRHS)]
defns, OMap Name DKind
sigs) <- (([Maybe (Name, ULetDecRHS)], [OMap Name DKind])
 -> ([(Name, ULetDecRHS)], OMap Name DKind))
-> m ([Maybe (Name, ULetDecRHS)], [OMap Name DKind])
-> m ([(Name, ULetDecRHS)], OMap Name DKind)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (([Maybe (Name, ULetDecRHS)] -> [(Name, ULetDecRHS)])
-> ([OMap Name DKind] -> OMap Name DKind)
-> ([Maybe (Name, ULetDecRHS)], [OMap Name DKind])
-> ([(Name, ULetDecRHS)], OMap Name DKind)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [Maybe (Name, ULetDecRHS)] -> [(Name, ULetDecRHS)]
forall a. [Maybe a] -> [a]
catMaybes [OMap Name DKind] -> OMap Name DKind
forall a. Monoid a => [a] -> a
mconcat) (m ([Maybe (Name, ULetDecRHS)], [OMap Name DKind])
 -> m ([(Name, ULetDecRHS)], OMap Name DKind))
-> m ([Maybe (Name, ULetDecRHS)], [OMap Name DKind])
-> m ([(Name, ULetDecRHS)], OMap Name DKind)
forall a b. (a -> b) -> a -> b
$
                   (DDec -> m (Maybe (Name, ULetDecRHS), OMap Name DKind))
-> [DDec] -> m ([Maybe (Name, ULetDecRHS)], [OMap Name DKind])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM DDec -> m (Maybe (Name, ULetDecRHS), OMap Name DKind)
forall (m :: * -> *).
MonadFail m =>
DDec -> m (Maybe (Name, ULetDecRHS), OMap Name DKind)
partitionInstanceDec [DDec]
decs
  (Name
name, DCxt
tys) <- DCxt -> DKind -> m (Name, DCxt)
forall (m :: * -> *).
MonadFail m =>
DCxt -> DKind -> m (Name, DCxt)
split_app_tys [] DKind
ty
  PartitionedDecs -> m PartitionedDecs
forall (m :: * -> *) a. Monad m => a -> m a
return (PartitionedDecs -> m PartitionedDecs)
-> PartitionedDecs -> m PartitionedDecs
forall a b. (a -> b) -> a -> b
$ PartitionedDecs
forall a. Monoid a => a
mempty { pd_instance_decs :: [UInstDecl]
pd_instance_decs = [InstDecl :: forall (ann :: AnnotationFlag).
DCxt
-> Name
-> DCxt
-> OMap Name DKind
-> [(Name, LetDecRHS ann)]
-> InstDecl ann
InstDecl { id_cxt :: DCxt
id_cxt       = DCxt
cxt
                                                 , id_name :: Name
id_name      = Name
name
                                                 , id_arg_tys :: DCxt
id_arg_tys   = DCxt
tys
                                                 , id_sigs :: OMap Name DKind
id_sigs      = OMap Name DKind
sigs
                                                 , id_meths :: [(Name, ULetDecRHS)]
id_meths     = [(Name, ULetDecRHS)]
defns }] }
  where
    split_app_tys :: DCxt -> DKind -> m (Name, DCxt)
split_app_tys DCxt
acc (DAppT DKind
t1 DKind
t2) = DCxt -> DKind -> m (Name, DCxt)
split_app_tys (DKind
t2DKind -> DCxt -> DCxt
forall a. a -> [a] -> [a]
:DCxt
acc) DKind
t1
    split_app_tys DCxt
acc (DConT Name
name)  = (Name, DCxt) -> m (Name, DCxt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, DCxt
acc)
    split_app_tys DCxt
acc (DSigT DKind
t DKind
_)   = DCxt -> DKind -> m (Name, DCxt)
split_app_tys DCxt
acc DKind
t
    split_app_tys DCxt
_ DKind
_ = String -> m (Name, DCxt)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (Name, DCxt)) -> String -> m (Name, DCxt)
forall a b. (a -> b) -> a -> b
$ String
"Illegal instance head: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DKind -> String
forall a. Show a => a -> String
show DKind
ty
partitionDec (DRoleAnnotD {}) = PartitionedDecs -> m PartitionedDecs
forall (m :: * -> *) a. Monad m => a -> m a
return PartitionedDecs
forall a. Monoid a => a
mempty  -- ignore these
partitionDec (DTySynD Name
name [DTyVarBndr]
tvbs DKind
rhs) =
  -- See Note [Partitioning, type synonyms, and type families]
  PartitionedDecs -> m PartitionedDecs
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PartitionedDecs -> m PartitionedDecs)
-> PartitionedDecs -> m PartitionedDecs
forall a b. (a -> b) -> a -> b
$ PartitionedDecs
forall a. Monoid a => a
mempty { pd_ty_syn_decs :: [TySynDecl]
pd_ty_syn_decs = [Name -> [DTyVarBndr] -> DKind -> TySynDecl
TySynDecl Name
name [DTyVarBndr]
tvbs DKind
rhs] }
partitionDec (DClosedTypeFamilyD DTypeFamilyHead
tf_head [DTySynEqn]
_) =
  -- See Note [Partitioning, type synonyms, and type families]
  PartitionedDecs -> m PartitionedDecs
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PartitionedDecs -> m PartitionedDecs)
-> PartitionedDecs -> m PartitionedDecs
forall a b. (a -> b) -> a -> b
$ PartitionedDecs
forall a. Monoid a => a
mempty { pd_closed_type_family_decs :: [ClosedTypeFamilyDecl]
pd_closed_type_family_decs = [DTypeFamilyHead -> ClosedTypeFamilyDecl
forall (info :: FamilyInfo). DTypeFamilyHead -> TypeFamilyDecl info
TypeFamilyDecl DTypeFamilyHead
tf_head] }
partitionDec (DOpenTypeFamilyD DTypeFamilyHead
tf_head) =
  -- See Note [Partitioning, type synonyms, and type families]
  PartitionedDecs -> m PartitionedDecs
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PartitionedDecs -> m PartitionedDecs)
-> PartitionedDecs -> m PartitionedDecs
forall a b. (a -> b) -> a -> b
$ PartitionedDecs
forall a. Monoid a => a
mempty { pd_open_type_family_decs :: [OpenTypeFamilyDecl]
pd_open_type_family_decs = [DTypeFamilyHead -> OpenTypeFamilyDecl
forall (info :: FamilyInfo). DTypeFamilyHead -> TypeFamilyDecl info
TypeFamilyDecl DTypeFamilyHead
tf_head] }
partitionDec (DTySynInstD {}) = PartitionedDecs -> m PartitionedDecs
forall (f :: * -> *) a. Applicative f => a -> f a
pure PartitionedDecs
forall a. Monoid a => a
mempty
  -- There's no need to track type family instances, since
  -- we already record the type family itself separately.
partitionDec (DKiSigD {}) = PartitionedDecs -> m PartitionedDecs
forall (f :: * -> *) a. Applicative f => a -> f a
pure PartitionedDecs
forall a. Monoid a => a
mempty
  -- There's no need to track standalone kind signatures, since we use
  -- dsReifyType to look them up.
partitionDec (DStandaloneDerivD Maybe DDerivStrategy
mb_strat Maybe [DTyVarBndr]
_ DCxt
ctxt DKind
ty) =
  case DKind -> (DKind, [DTypeArg])
unfoldDType DKind
ty of
    (DKind
cls_pred_ty, [DTypeArg]
cls_tys)
      | let cls_normal_tys :: DCxt
cls_normal_tys = [DTypeArg] -> DCxt
filterDTANormals [DTypeArg]
cls_tys
      , Bool -> Bool
not (DCxt -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null DCxt
cls_normal_tys) -- We can't handle zero-parameter type classes
      , let cls_arg_tys :: DCxt
cls_arg_tys  = DCxt -> DCxt
forall a. [a] -> [a]
init DCxt
cls_normal_tys
            data_ty :: DKind
data_ty      = DCxt -> DKind
forall a. [a] -> a
last DCxt
cls_normal_tys
            data_ty_head :: DKind
data_ty_head = case DKind -> (DKind, [DTypeArg])
unfoldDType DKind
data_ty of (DKind
ty_head, [DTypeArg]
_) -> DKind
ty_head
      , DConT Name
data_tycon <- DKind
data_ty_head -- We can't handle deriving an instance for something
                                         -- other than a type constructor application
      -> do let cls_pred :: DKind
cls_pred = DKind -> DCxt -> DKind
foldType DKind
cls_pred_ty DCxt
cls_arg_tys
            Maybe DInfo
dinfo <- Name -> m (Maybe DInfo)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReify Name
data_tycon
            case Maybe DInfo
dinfo of
              Just (DTyConI (DDataD NewOrData
_ DCxt
_ Name
dn [DTyVarBndr]
dtvbs Maybe DKind
dk [DCon]
dcons [DDerivClause]
_) Maybe [DDec]
_) -> do
                [DTyVarBndr]
all_tvbs <- [DTyVarBndr] -> Maybe DKind -> m [DTyVarBndr]
forall (q :: * -> *).
DsMonad q =>
[DTyVarBndr] -> Maybe DKind -> q [DTyVarBndr]
buildDataDTvbs [DTyVarBndr]
dtvbs Maybe DKind
dk
                let data_decl :: DataDecl
data_decl = Name -> [DTyVarBndr] -> [DCon] -> DataDecl
DataDecl Name
dn [DTyVarBndr]
all_tvbs [DCon]
dcons
                Maybe DDerivStrategy
-> DKind -> Maybe DCxt -> DKind -> DataDecl -> m PartitionedDecs
forall (m :: * -> *).
OptionsMonad m =>
Maybe DDerivStrategy
-> DKind -> Maybe DCxt -> DKind -> DataDecl -> m PartitionedDecs
partitionDeriving Maybe DDerivStrategy
mb_strat DKind
cls_pred (DCxt -> Maybe DCxt
forall a. a -> Maybe a
Just DCxt
ctxt) DKind
data_ty DataDecl
data_decl
              Just DInfo
_ ->
                String -> m PartitionedDecs
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m PartitionedDecs) -> String -> m PartitionedDecs
forall a b. (a -> b) -> a -> b
$ String
"Standalone derived instance for something other than a datatype: "
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ DKind -> String
forall a. Show a => a -> String
show DKind
data_ty
              Maybe DInfo
_ -> String -> m PartitionedDecs
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m PartitionedDecs) -> String -> m PartitionedDecs
forall a b. (a -> b) -> a -> b
$ String
"Cannot find " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DKind -> String
forall a. Show a => a -> String
show DKind
data_ty
    (DKind, [DTypeArg])
_ -> PartitionedDecs -> m PartitionedDecs
forall (m :: * -> *) a. Monad m => a -> m a
return PartitionedDecs
forall a. Monoid a => a
mempty
partitionDec DDec
dec =
  String -> m PartitionedDecs
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m PartitionedDecs) -> String -> m PartitionedDecs
forall a b. (a -> b) -> a -> b
$ String
"Declaration cannot be promoted: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Dec] -> String
forall a. Ppr a => a -> String
pprint (DDec -> [Dec]
decToTH DDec
dec)

partitionClassDec :: MonadFail m => DDec -> m (ULetDecEnv, [OpenTypeFamilyDecl])
partitionClassDec :: DDec -> m (ULetDecEnv, [OpenTypeFamilyDecl])
partitionClassDec (DLetDec (DSigD Name
name DKind
ty)) =
  (ULetDecEnv, [OpenTypeFamilyDecl])
-> m (ULetDecEnv, [OpenTypeFamilyDecl])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> DKind -> ULetDecEnv
typeBinding Name
name DKind
ty, [OpenTypeFamilyDecl]
forall a. Monoid a => a
mempty)
partitionClassDec (DLetDec (DValD (DVarP Name
name) DExp
exp)) =
  (ULetDecEnv, [OpenTypeFamilyDecl])
-> m (ULetDecEnv, [OpenTypeFamilyDecl])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> ULetDecRHS -> ULetDecEnv
valueBinding Name
name (DExp -> ULetDecRHS
UValue DExp
exp), [OpenTypeFamilyDecl]
forall a. Monoid a => a
mempty)
partitionClassDec (DLetDec (DFunD Name
name [DClause]
clauses)) =
  (ULetDecEnv, [OpenTypeFamilyDecl])
-> m (ULetDecEnv, [OpenTypeFamilyDecl])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> ULetDecRHS -> ULetDecEnv
valueBinding Name
name ([DClause] -> ULetDecRHS
UFunction [DClause]
clauses), [OpenTypeFamilyDecl]
forall a. Monoid a => a
mempty)
partitionClassDec (DLetDec (DInfixD Fixity
fixity Name
name)) =
  (ULetDecEnv, [OpenTypeFamilyDecl])
-> m (ULetDecEnv, [OpenTypeFamilyDecl])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Fixity -> Name -> ULetDecEnv
infixDecl Fixity
fixity Name
name, [OpenTypeFamilyDecl]
forall a. Monoid a => a
mempty)
partitionClassDec (DLetDec (DPragmaD {})) =
  (ULetDecEnv, [OpenTypeFamilyDecl])
-> m (ULetDecEnv, [OpenTypeFamilyDecl])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ULetDecEnv
forall a. Monoid a => a
mempty, [OpenTypeFamilyDecl]
forall a. Monoid a => a
mempty)
partitionClassDec (DOpenTypeFamilyD DTypeFamilyHead
tf_head) =
  -- See Note [Partitioning, type synonyms, and type families]
  (ULetDecEnv, [OpenTypeFamilyDecl])
-> m (ULetDecEnv, [OpenTypeFamilyDecl])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ULetDecEnv
forall a. Monoid a => a
mempty, [DTypeFamilyHead -> OpenTypeFamilyDecl
forall (info :: FamilyInfo). DTypeFamilyHead -> TypeFamilyDecl info
TypeFamilyDecl DTypeFamilyHead
tf_head])
partitionClassDec (DTySynInstD {}) =
  -- There's no need to track associated type family default equations, since
  -- we already record the type family itself separately.
  (ULetDecEnv, [OpenTypeFamilyDecl])
-> m (ULetDecEnv, [OpenTypeFamilyDecl])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ULetDecEnv
forall a. Monoid a => a
mempty, [OpenTypeFamilyDecl]
forall a. Monoid a => a
mempty)
partitionClassDec DDec
_ =
  String -> m (ULetDecEnv, [OpenTypeFamilyDecl])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Only method declarations can be promoted within a class."

partitionInstanceDec :: MonadFail m => DDec
                     -> m ( Maybe (Name, ULetDecRHS) -- right-hand sides of methods
                          , OMap Name DType          -- method type signatures
                          )
partitionInstanceDec :: DDec -> m (Maybe (Name, ULetDecRHS), OMap Name DKind)
partitionInstanceDec (DLetDec (DValD (DVarP Name
name) DExp
exp)) =
  (Maybe (Name, ULetDecRHS), OMap Name DKind)
-> m (Maybe (Name, ULetDecRHS), OMap Name DKind)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Name, ULetDecRHS) -> Maybe (Name, ULetDecRHS)
forall a. a -> Maybe a
Just (Name
name, DExp -> ULetDecRHS
UValue DExp
exp), OMap Name DKind
forall a. Monoid a => a
mempty)
partitionInstanceDec (DLetDec (DFunD Name
name [DClause]
clauses)) =
  (Maybe (Name, ULetDecRHS), OMap Name DKind)
-> m (Maybe (Name, ULetDecRHS), OMap Name DKind)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Name, ULetDecRHS) -> Maybe (Name, ULetDecRHS)
forall a. a -> Maybe a
Just (Name
name, [DClause] -> ULetDecRHS
UFunction [DClause]
clauses), OMap Name DKind
forall a. Monoid a => a
mempty)
partitionInstanceDec (DLetDec (DSigD Name
name DKind
ty)) =
  (Maybe (Name, ULetDecRHS), OMap Name DKind)
-> m (Maybe (Name, ULetDecRHS), OMap Name DKind)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Name, ULetDecRHS)
forall a. Maybe a
Nothing, Name -> DKind -> OMap Name DKind
forall k v. k -> v -> OMap k v
OMap.singleton Name
name DKind
ty)
partitionInstanceDec (DLetDec (DPragmaD {})) =
  (Maybe (Name, ULetDecRHS), OMap Name DKind)
-> m (Maybe (Name, ULetDecRHS), OMap Name DKind)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Name, ULetDecRHS)
forall a. Maybe a
Nothing, OMap Name DKind
forall a. Monoid a => a
mempty)
partitionInstanceDec (DTySynInstD {}) =
  (Maybe (Name, ULetDecRHS), OMap Name DKind)
-> m (Maybe (Name, ULetDecRHS), OMap Name DKind)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Name, ULetDecRHS)
forall a. Maybe a
Nothing, OMap Name DKind
forall a. Monoid a => a
mempty)
  -- There's no need to track associated type family instances, since
  -- we already record the type family itself separately.
partitionInstanceDec DDec
_ =
  String -> m (Maybe (Name, ULetDecRHS), OMap Name DKind)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Only method bodies can be promoted within an instance."

partitionDeriving
  :: forall m. OptionsMonad m
  => Maybe DDerivStrategy
                -- ^ The deriving strategy, if present.
  -> DPred      -- ^ The class being derived (e.g., 'Eq'), possibly applied to
                --   some number of arguments (e.g., @C Int Bool@).
  -> Maybe DCxt -- ^ @'Just' ctx@ if @ctx@ was provided via @StandaloneDeriving@.
                --   'Nothing' if using a @deriving@ clause.
  -> DType      -- ^ The data type argument to the class.
  -> DataDecl   -- ^ The original data type information (e.g., its constructors).
  -> m PartitionedDecs
partitionDeriving :: Maybe DDerivStrategy
-> DKind -> Maybe DCxt -> DKind -> DataDecl -> m PartitionedDecs
partitionDeriving Maybe DDerivStrategy
mb_strat DKind
deriv_pred Maybe DCxt
mb_ctxt DKind
ty DataDecl
data_decl =
  case DKind -> (DKind, [DTypeArg])
unfoldDType DKind
deriv_pred of
    (DConT Name
deriv_name, [DTypeArg]
arg_tys)
         -- Here, we are more conservative than GHC: DeriveAnyClass only kicks
         -- in if the user explicitly chooses to do so with the anyclass
         -- deriving strategy
       | Just DDerivStrategy
DAnyclassStrategy <- Maybe DDerivStrategy
mb_strat
      -> PartitionedDecs -> m PartitionedDecs
forall (m :: * -> *) a. Monad m => a -> m a
return (PartitionedDecs -> m PartitionedDecs)
-> PartitionedDecs -> m PartitionedDecs
forall a b. (a -> b) -> a -> b
$ UInstDecl -> PartitionedDecs
mk_derived_inst
           InstDecl :: forall (ann :: AnnotationFlag).
DCxt
-> Name
-> DCxt
-> OMap Name DKind
-> [(Name, LetDecRHS ann)]
-> InstDecl ann
InstDecl { id_cxt :: DCxt
id_cxt = DCxt -> Maybe DCxt -> DCxt
forall a. a -> Maybe a -> a
fromMaybe [] Maybe DCxt
mb_ctxt
                      -- For now at least, there's no point in attempting to
                      -- infer an instance context for DeriveAnyClass, since
                      -- the other language feature that requires it,
                      -- DefaultSignatures, can't be singled. Thus, inferring an
                      -- empty context will Just Work for all currently supported
                      -- default implementations.
                      --
                      -- (Of course, if a user specifies a context with
                      -- StandaloneDeriving, use that.)

                    , id_name :: Name
id_name      = Name
deriv_name
                    , id_arg_tys :: DCxt
id_arg_tys   = [DTypeArg] -> DCxt
filterDTANormals [DTypeArg]
arg_tys DCxt -> DCxt -> DCxt
forall a. [a] -> [a] -> [a]
++ [DKind
ty]
                    , id_sigs :: OMap Name DKind
id_sigs      = OMap Name DKind
forall a. Monoid a => a
mempty
                    , id_meths :: [(Name, ULetDecRHS)]
id_meths     = [] }

       | Just DDerivStrategy
DNewtypeStrategy <- Maybe DDerivStrategy
mb_strat
      -> do String -> m ()
forall (q :: * -> *). Quasi q => String -> q ()
qReportWarning String
"GeneralizedNewtypeDeriving is ignored by `singletons`."
            PartitionedDecs -> m PartitionedDecs
forall (m :: * -> *) a. Monad m => a -> m a
return PartitionedDecs
forall a. Monoid a => a
mempty

       | Just (DViaStrategy {}) <- Maybe DDerivStrategy
mb_strat
      -> do String -> m ()
forall (q :: * -> *). Quasi q => String -> q ()
qReportWarning String
"DerivingVia is ignored by `singletons`."
            PartitionedDecs -> m PartitionedDecs
forall (m :: * -> *) a. Monad m => a -> m a
return PartitionedDecs
forall a. Monoid a => a
mempty

    -- Stock classes. These are derived only if `singletons` supports them
    -- (and, optionally, if an explicit stock deriving strategy is used)
    (DConT Name
deriv_name, []) -- For now, all stock derivable class supported in
                           -- singletons take just one argument (the data
                           -- type itself)
       | Bool
stock_or_default
       , Just m PartitionedDecs
decs <- Name -> Map Name (m PartitionedDecs) -> Maybe (m PartitionedDecs)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
deriv_name Map Name (m PartitionedDecs)
stock_map
      -> m PartitionedDecs
decs

         -- If we can't find a stock class, but the user bothered to use an
         -- explicit stock keyword, we can at least warn them about it.
       | Just DDerivStrategy
DStockStrategy <- Maybe DDerivStrategy
mb_strat
      -> do String -> m ()
forall (q :: * -> *). Quasi q => String -> q ()
qReportWarning (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"`singletons` doesn't recognize the stock class "
                             String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
deriv_name
            PartitionedDecs -> m PartitionedDecs
forall (m :: * -> *) a. Monad m => a -> m a
return PartitionedDecs
forall a. Monoid a => a
mempty

    (DKind, [DTypeArg])
_ -> PartitionedDecs -> m PartitionedDecs
forall (m :: * -> *) a. Monad m => a -> m a
return PartitionedDecs
forall a. Monoid a => a
mempty -- singletons doesn't support deriving this instance
  where
      mk_instance :: DerivDesc m -> m UInstDecl
      mk_instance :: DerivDesc m -> m UInstDecl
mk_instance DerivDesc m
maker = DerivDesc m
maker Maybe DCxt
mb_ctxt DKind
ty DataDecl
data_decl

      mk_derived_inst :: UInstDecl -> PartitionedDecs
mk_derived_inst    UInstDecl
dec = PartitionedDecs
forall a. Monoid a => a
mempty { pd_instance_decs :: [UInstDecl]
pd_instance_decs   = [UInstDecl
dec] }
      mk_derived_eq_inst :: DerivedEqDecl -> PartitionedDecs
mk_derived_eq_inst DerivedEqDecl
dec = PartitionedDecs
forall a. Monoid a => a
mempty { pd_derived_eq_decs :: [DerivedEqDecl]
pd_derived_eq_decs = [DerivedEqDecl
dec] }

      derived_decl :: DerivedDecl cls
      derived_decl :: DerivedDecl cls
derived_decl = DerivedDecl :: forall (cls :: * -> Constraint).
Maybe DCxt -> DKind -> Name -> DataDecl -> DerivedDecl cls
DerivedDecl { ded_mb_cxt :: Maybe DCxt
ded_mb_cxt     = Maybe DCxt
mb_ctxt
                                 , ded_type :: DKind
ded_type       = DKind
ty
                                 , ded_type_tycon :: Name
ded_type_tycon = Name
ty_tycon
                                 , ded_decl :: DataDecl
ded_decl       = DataDecl
data_decl }
        where
          ty_tycon :: Name
          ty_tycon :: Name
ty_tycon = case DKind -> (DKind, [DTypeArg])
unfoldDType DKind
ty of
                       (DConT Name
tc, [DTypeArg]
_) -> Name
tc
                       (DKind
t,        [DTypeArg]
_) -> String -> Name
forall a. HasCallStack => String -> a
error (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"Not a data type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DKind -> String
forall a. Show a => a -> String
show DKind
t
      stock_or_default :: Bool
stock_or_default = Maybe DDerivStrategy -> Bool
isStockOrDefault Maybe DDerivStrategy
mb_strat

      -- A mapping from all stock derivable classes (that singletons supports)
      -- to to derived code that they produce.
      stock_map :: Map Name (m PartitionedDecs)
      stock_map :: Map Name (m PartitionedDecs)
stock_map = [(Name, m PartitionedDecs)] -> Map Name (m PartitionedDecs)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ ( Name
ordName,         UInstDecl -> PartitionedDecs
mk_derived_inst (UInstDecl -> PartitionedDecs) -> m UInstDecl -> m PartitionedDecs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DerivDesc m -> m UInstDecl
mk_instance DerivDesc m
forall (q :: * -> *). DsMonad q => DerivDesc q
mkOrdInstance )
        , ( Name
boundedName,     UInstDecl -> PartitionedDecs
mk_derived_inst (UInstDecl -> PartitionedDecs) -> m UInstDecl -> m PartitionedDecs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DerivDesc m -> m UInstDecl
mk_instance DerivDesc m
forall (q :: * -> *). DsMonad q => DerivDesc q
mkBoundedInstance )
        , ( Name
enumName,        UInstDecl -> PartitionedDecs
mk_derived_inst (UInstDecl -> PartitionedDecs) -> m UInstDecl -> m PartitionedDecs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DerivDesc m -> m UInstDecl
mk_instance DerivDesc m
forall (q :: * -> *). DsMonad q => DerivDesc q
mkEnumInstance )
        , ( Name
functorName,     UInstDecl -> PartitionedDecs
mk_derived_inst (UInstDecl -> PartitionedDecs) -> m UInstDecl -> m PartitionedDecs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DerivDesc m -> m UInstDecl
mk_instance DerivDesc m
forall (q :: * -> *). DsMonad q => DerivDesc q
mkFunctorInstance )
        , ( Name
foldableName,    UInstDecl -> PartitionedDecs
mk_derived_inst (UInstDecl -> PartitionedDecs) -> m UInstDecl -> m PartitionedDecs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DerivDesc m -> m UInstDecl
mk_instance DerivDesc m
forall (q :: * -> *). DsMonad q => DerivDesc q
mkFoldableInstance )
        , ( Name
traversableName, UInstDecl -> PartitionedDecs
mk_derived_inst (UInstDecl -> PartitionedDecs) -> m UInstDecl -> m PartitionedDecs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DerivDesc m -> m UInstDecl
mk_instance DerivDesc m
forall (q :: * -> *). DsMonad q => DerivDesc q
mkTraversableInstance )
          -- See Note [DerivedDecl] in Data.Singletons.Syntax
        , ( Name
eqName, PartitionedDecs -> m PartitionedDecs
forall (m :: * -> *) a. Monad m => a -> m a
return (PartitionedDecs -> m PartitionedDecs)
-> PartitionedDecs -> m PartitionedDecs
forall a b. (a -> b) -> a -> b
$ DerivedEqDecl -> PartitionedDecs
mk_derived_eq_inst DerivedEqDecl
forall (cls :: * -> Constraint). DerivedDecl cls
derived_decl )
          -- See Note [DerivedDecl] in Data.Singletons.Syntax
        , ( Name
showName, do -- These will become PShow/SShow instances...
                         UInstDecl
inst_for_promotion <- DerivDesc m -> m UInstDecl
mk_instance (DerivDesc m -> m UInstDecl) -> DerivDesc m -> m UInstDecl
forall a b. (a -> b) -> a -> b
$ ShowMode -> DerivDesc m
forall (q :: * -> *). OptionsMonad q => ShowMode -> DerivDesc q
mkShowInstance ShowMode
ForPromotion
                         -- ...and this will become a Show instance.
                         let inst_for_show :: DerivedDecl cls
inst_for_show = DerivedDecl cls
forall (cls :: * -> Constraint). DerivedDecl cls
derived_decl
                         PartitionedDecs -> m PartitionedDecs
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PartitionedDecs -> m PartitionedDecs)
-> PartitionedDecs -> m PartitionedDecs
forall a b. (a -> b) -> a -> b
$ PartitionedDecs
forall a. Monoid a => a
mempty { pd_instance_decs :: [UInstDecl]
pd_instance_decs     = [UInstDecl
inst_for_promotion]
                                       , pd_derived_show_decs :: [DerivedShowDecl]
pd_derived_show_decs = [DerivedShowDecl
forall (cls :: * -> Constraint). DerivedDecl cls
inst_for_show] } )
        ]

-- Is this being used with an explicit stock strategy, or no strategy at all?
isStockOrDefault :: Maybe DDerivStrategy -> Bool
isStockOrDefault :: Maybe DDerivStrategy -> Bool
isStockOrDefault Maybe DDerivStrategy
Nothing               = Bool
True
isStockOrDefault (Just DDerivStrategy
DStockStrategy) = Bool
True
isStockOrDefault (Just DDerivStrategy
_)              = Bool
False

{-
Note [Partitioning, type synonyms, and type families]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The process of singling does not produce any new declarations corresponding to
type synonyms or type families, so they are "ignored" in a sense. Nevertheless,
we explicitly track them during partitioning, since we want to create
defunctionalization symbols for them.

Also note that:

1. Other uses of type synonyms in singled code will be expanded away.
2. Other uses of type families in singled code are unlikely to work at present
   due to Trac #12564.
3. We track open type families, closed type families, and associated type
   families separately, as each form of type family has different kind
   inference behavior. See defunTopLevelTypeDecls and
   defunAssociatedTypeFamilies in D.S.Promote.Defun for how these differences
   manifest.
-}