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

-- | Split up a @[DDec]@ into its pieces, extracting 'Ord' instances
-- from deriving clauses
partitionDecs :: DsMonad 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 :: * -> *). DsMonad m => DDec -> m PartitionedDecs
partitionDec

partitionDec :: DsMonad 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 letdec :: 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 _nd :: NewOrData
_nd _cxt :: DCxt
_cxt name :: Name
name tvbs :: [DTyVarBndr]
tvbs mk :: Maybe DKind
mk cons :: [DCon]
cons derivings :: [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 (\(strat :: Maybe DDerivStrategy
strat, deriv_pred :: DKind
deriv_pred) ->
              let etad_tvbs :: [DTyVarBndr]
etad_tvbs
                    | (DConT pred_name :: Name
pred_name, _) <- 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
- 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 :: * -> *).
DsMonad 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 strat :: Maybe DDerivStrategy
strat preds :: DCxt
preds) =
      (DKind -> (Maybe DDerivStrategy, DKind))
-> DCxt -> [(Maybe DDerivStrategy, DKind)]
forall a b. (a -> b) -> [a] -> [b]
map (\p :: DKind
p -> (Maybe DDerivStrategy
strat, DKind
p)) DCxt
preds

partitionDec (DClassD cxt :: DCxt
cxt name :: Name
name tvbs :: [DTyVarBndr]
tvbs fds :: [FunDep]
fds decs :: [DDec]
decs) = do
  (lde :: ULetDecEnv
lde, otfs :: [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
-> 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 }]
                  , pd_open_type_family_decs :: [OpenTypeFamilyDecl]
pd_open_type_family_decs = [OpenTypeFamilyDecl]
otfs }
partitionDec (DInstanceD _ _ cxt :: DCxt
cxt ty :: DKind
ty decs :: [DDec]
decs) = do
  (defns :: [(Name, ULetDecRHS)]
defns, sigs :: 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
name, tys :: 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 acc :: DCxt
acc (DAppT t1 :: DKind
t1 t2 :: 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 acc :: DCxt
acc (DConT name :: Name
name)  = (Name, DCxt) -> m (Name, DCxt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, DCxt
acc)
    split_app_tys acc :: DCxt
acc (DSigT t :: DKind
t _)   = DCxt -> DKind -> m (Name, DCxt)
split_app_tys DCxt
acc DKind
t
    split_app_tys _ _ = 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
$ "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
name tvbs :: [DTyVarBndr]
tvbs rhs :: 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 tf_head :: 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_closed_type_family_decs :: [ClosedTypeFamilyDecl]
pd_closed_type_family_decs = [DTypeFamilyHead -> ClosedTypeFamilyDecl
forall (info :: FamilyInfo). DTypeFamilyHead -> TypeFamilyDecl info
TypeFamilyDecl DTypeFamilyHead
tf_head] }
partitionDec (DOpenTypeFamilyD tf_head :: 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 (DStandaloneDerivD mb_strat :: Maybe DDerivStrategy
mb_strat _ ctxt :: DCxt
ctxt ty :: DKind
ty) =
  case DKind -> (DKind, [DTypeArg])
unfoldDType DKind
ty of
    (cls_pred_ty :: DKind
cls_pred_ty, cls_tys :: [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 (ty_head :: DKind
ty_head, _) -> DKind
ty_head
      , DConT data_tycon :: 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 _ _ dn :: Name
dn dtvbs :: [DTyVarBndr]
dtvbs dk :: Maybe DKind
dk dcons :: [DCon]
dcons _) _) -> 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 :: * -> *).
DsMonad 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 _ ->
                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
$ "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
              _ -> 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
$ "Cannot find " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DKind -> String
forall a. Show a => a -> String
show DKind
data_ty
    _ -> PartitionedDecs -> m PartitionedDecs
forall (m :: * -> *) a. Monad m => a -> m a
return PartitionedDecs
forall a. Monoid a => a
mempty
partitionDec dec :: 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
$ "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
name ty :: 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
name) exp :: 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
name clauses :: [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
fixity name :: 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 tf_head :: 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 _ =
  String -> m (ULetDecEnv, [OpenTypeFamilyDecl])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "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
name) exp :: 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
name clauses :: [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
name ty :: 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 _ =
  String -> m (Maybe (Name, ULetDecRHS), OMap Name DKind)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Only method bodies can be promoted within an instance."

partitionDeriving
  :: forall m. DsMonad 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 mb_strat :: Maybe DDerivStrategy
mb_strat deriv_pred :: DKind
deriv_pred mb_ctxt :: Maybe DCxt
mb_ctxt ty :: DKind
ty data_decl :: DataDecl
data_decl =
  case DKind -> (DKind, [DTypeArg])
unfoldDType DKind
deriv_pred of
    (DConT deriv_name :: Name
deriv_name, arg_tys :: [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 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 DNewtypeStrategy <- Maybe DDerivStrategy
mb_strat
      -> do String -> m ()
forall (q :: * -> *). Quasi q => String -> q ()
qReportWarning "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 "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 deriv_name :: 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 decs :: 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 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
$ "`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

    _ -> 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 maker :: DerivDesc m
maker = DerivDesc m
maker Maybe DCxt
mb_ctxt DKind
ty DataDecl
data_decl

      mk_derived_inst :: UInstDecl -> PartitionedDecs
mk_derived_inst    dec :: 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 dec :: 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 tc :: Name
tc, _) -> Name
tc
                       (t :: DKind
t,        _) -> String -> Name
forall a. HasCallStack => String -> a
error (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ "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 :: * -> *). DsMonad 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 Nothing               = Bool
True
isStockOrDefault (Just DStockStrategy) = Bool
True
isStockOrDefault (Just _)              = 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.
-}