module Data.Singletons.TH.Partition where
import Prelude hiding ( exp )
import Data.Singletons.TH.Deriving.Bounded
import Data.Singletons.TH.Deriving.Enum
import Data.Singletons.TH.Deriving.Eq
import Data.Singletons.TH.Deriving.Foldable
import Data.Singletons.TH.Deriving.Functor
import Data.Singletons.TH.Deriving.Ord
import Data.Singletons.TH.Deriving.Show
import Data.Singletons.TH.Deriving.Traversable
import Data.Singletons.TH.Deriving.Util
import Data.Singletons.TH.Names
import Data.Singletons.TH.Options
import Data.Singletons.TH.Syntax
import Data.Singletons.TH.Util
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 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
partitionDecs :: OptionsMonad m => [DDec] -> m PartitionedDecs
partitionDecs :: forall (m :: * -> *). OptionsMonad m => [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 :: forall (m :: * -> *). OptionsMonad m => DDec -> m PartitionedDecs
partitionDec (DLetDec (DPragmaD {})) = PartitionedDecs -> m PartitionedDecs
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PartitionedDecs
forall a. Monoid a => a
mempty
partitionDec (DLetDec DLetDec
letdec) = PartitionedDecs -> m PartitionedDecs
forall a. a -> m a
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 = [letdec] }
partitionDec (DDataD DataFlavor
df DCxt
_cxt Name
name [DTyVarBndrUnit]
tvbs Maybe DType
mk [DCon]
cons [DDerivClause]
derivings) = do
[DTyVarBndrUnit]
all_tvbs <- [DTyVarBndrUnit] -> Maybe DType -> m [DTyVarBndrUnit]
forall (q :: * -> *).
DsMonad q =>
[DTyVarBndrUnit] -> Maybe DType -> q [DTyVarBndrUnit]
buildDataDTvbs [DTyVarBndrUnit]
tvbs Maybe DType
mk
let data_decl :: DataDecl
data_decl = DataFlavor -> Name -> [DTyVarBndrUnit] -> [DCon] -> DataDecl
DataDecl DataFlavor
df Name
name [DTyVarBndrUnit]
all_tvbs [DCon]
cons
derived_dec :: PartitionedDecs
derived_dec = PartitionedDecs
forall a. Monoid a => a
mempty { pd_data_decs = [data_decl] }
[PartitionedDecs]
derived_decs
<- ((Maybe DDerivStrategy, DType) -> m PartitionedDecs)
-> [(Maybe DDerivStrategy, DType)] -> m [PartitionedDecs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Maybe DDerivStrategy
strat, DType
deriv_pred) ->
let etad_tvbs :: [DTyVarBndrUnit]
etad_tvbs
| (DConT Name
pred_name, [DTypeArg]
_) <- DType -> (DType, [DTypeArg])
unfoldDType DType
deriv_pred
, Name -> Bool
isFunctorLikeClassName Name
pred_name
= Int -> [DTyVarBndrUnit] -> [DTyVarBndrUnit]
forall a. Int -> [a] -> [a]
take ([DTyVarBndrUnit] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DTyVarBndrUnit]
all_tvbs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [DTyVarBndrUnit]
all_tvbs
| Bool
otherwise
= [DTyVarBndrUnit]
all_tvbs
ty :: DType
ty = DType -> [DTyVarBndrUnit] -> DType
forall flag. DType -> [DTyVarBndr flag] -> DType
foldTypeTvbs (Name -> DType
DConT Name
name) [DTyVarBndrUnit]
etad_tvbs
in Maybe DDerivStrategy
-> DType -> Maybe DCxt -> DType -> DataDecl -> m PartitionedDecs
forall (m :: * -> *).
OptionsMonad m =>
Maybe DDerivStrategy
-> DType -> Maybe DCxt -> DType -> DataDecl -> m PartitionedDecs
partitionDeriving Maybe DDerivStrategy
strat DType
deriv_pred Maybe DCxt
forall a. Maybe a
Nothing DType
ty DataDecl
data_decl)
([(Maybe DDerivStrategy, DType)] -> m [PartitionedDecs])
-> [(Maybe DDerivStrategy, DType)] -> m [PartitionedDecs]
forall a b. (a -> b) -> a -> b
$ (DDerivClause -> [(Maybe DDerivStrategy, DType)])
-> [DDerivClause] -> [(Maybe DDerivStrategy, DType)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DDerivClause -> [(Maybe DDerivStrategy, DType)]
flatten_clause [DDerivClause]
derivings
PartitionedDecs -> m PartitionedDecs
forall a. a -> m a
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, DType)]
flatten_clause (DDerivClause Maybe DDerivStrategy
strat DCxt
preds) =
(DType -> (Maybe DDerivStrategy, DType))
-> DCxt -> [(Maybe DDerivStrategy, DType)]
forall a b. (a -> b) -> [a] -> [b]
map (\DType
p -> (Maybe DDerivStrategy
strat, DType
p)) DCxt
preds
partitionDec (DClassD DCxt
cxt Name
name [DTyVarBndrUnit]
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 a. a -> m a
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 = [ClassDecl { cd_cxt = cxt
, cd_name = name
, cd_tvbs = tvbs
, cd_fds = fds
, cd_lde = lde
, cd_atfs = otfs}] }
partitionDec (DInstanceD Maybe Overlap
_ Maybe [DTyVarBndrUnit]
_ DCxt
cxt DType
ty [DDec]
decs) = do
([(Name, ULetDecRHS)]
defns, OMap Name DType
sigs) <- (([Maybe (Name, ULetDecRHS)], [OMap Name DType])
-> ([(Name, ULetDecRHS)], OMap Name DType))
-> m ([Maybe (Name, ULetDecRHS)], [OMap Name DType])
-> m ([(Name, ULetDecRHS)], OMap Name DType)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (([Maybe (Name, ULetDecRHS)] -> [(Name, ULetDecRHS)])
-> ([OMap Name DType] -> OMap Name DType)
-> ([Maybe (Name, ULetDecRHS)], [OMap Name DType])
-> ([(Name, ULetDecRHS)], OMap Name DType)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
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 DType] -> OMap Name DType
forall a. Monoid a => [a] -> a
mconcat) (m ([Maybe (Name, ULetDecRHS)], [OMap Name DType])
-> m ([(Name, ULetDecRHS)], OMap Name DType))
-> m ([Maybe (Name, ULetDecRHS)], [OMap Name DType])
-> m ([(Name, ULetDecRHS)], OMap Name DType)
forall a b. (a -> b) -> a -> b
$
(DDec -> m (Maybe (Name, ULetDecRHS), OMap Name DType))
-> [DDec] -> m ([Maybe (Name, ULetDecRHS)], [OMap Name DType])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM DDec -> m (Maybe (Name, ULetDecRHS), OMap Name DType)
forall (m :: * -> *).
MonadFail m =>
DDec -> m (Maybe (Name, ULetDecRHS), OMap Name DType)
partitionInstanceDec [DDec]
decs
(Name
name, DCxt
tys) <- DCxt -> DType -> m (Name, DCxt)
forall {m :: * -> *}.
MonadFail m =>
DCxt -> DType -> m (Name, DCxt)
split_app_tys [] DType
ty
PartitionedDecs -> m PartitionedDecs
forall a. a -> m a
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 = [InstDecl { id_cxt = cxt
, id_name = name
, id_arg_tys = tys
, id_sigs = sigs
, id_meths = defns }] }
where
split_app_tys :: DCxt -> DType -> m (Name, DCxt)
split_app_tys DCxt
acc (DAppT DType
t1 DType
t2) = DCxt -> DType -> m (Name, DCxt)
split_app_tys (DType
t2DType -> DCxt -> DCxt
forall a. a -> [a] -> [a]
:DCxt
acc) DType
t1
split_app_tys DCxt
acc (DConT Name
name) = (Name, DCxt) -> m (Name, DCxt)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, DCxt
acc)
split_app_tys DCxt
acc (DSigT DType
t DType
_) = DCxt -> DType -> m (Name, DCxt)
split_app_tys DCxt
acc DType
t
split_app_tys DCxt
_ DType
_ = String -> m (Name, DCxt)
forall a. String -> m a
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]
++ DType -> String
forall a. Show a => a -> String
show DType
ty
partitionDec (DRoleAnnotD {}) = PartitionedDecs -> m PartitionedDecs
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PartitionedDecs
forall a. Monoid a => a
mempty
partitionDec (DTySynD Name
name [DTyVarBndrUnit]
tvbs DType
rhs) =
PartitionedDecs -> m PartitionedDecs
forall a. a -> m a
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 name tvbs rhs] }
partitionDec (DClosedTypeFamilyD DTypeFamilyHead
tf_head [DTySynEqn]
_) =
PartitionedDecs -> m PartitionedDecs
forall a. a -> m a
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 = [TypeFamilyDecl tf_head] }
partitionDec (DOpenTypeFamilyD DTypeFamilyHead
tf_head) =
PartitionedDecs -> m PartitionedDecs
forall a. a -> m a
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 = [TypeFamilyDecl tf_head] }
partitionDec (DTySynInstD {}) = PartitionedDecs -> m PartitionedDecs
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PartitionedDecs
forall a. Monoid a => a
mempty
partitionDec (DKiSigD {}) = PartitionedDecs -> m PartitionedDecs
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PartitionedDecs
forall a. Monoid a => a
mempty
partitionDec (DStandaloneDerivD Maybe DDerivStrategy
mb_strat Maybe [DTyVarBndrUnit]
_ DCxt
ctxt DType
ty) =
case DType -> (DType, [DTypeArg])
unfoldDType DType
ty of
(DType
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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null DCxt
cls_normal_tys)
, let cls_arg_tys :: DCxt
cls_arg_tys = DCxt -> DCxt
forall a. HasCallStack => [a] -> [a]
init DCxt
cls_normal_tys
data_ty :: DType
data_ty = DCxt -> DType
forall a. HasCallStack => [a] -> a
last DCxt
cls_normal_tys
data_ty_head :: DType
data_ty_head = case DType -> (DType, [DTypeArg])
unfoldDType DType
data_ty of (DType
ty_head, [DTypeArg]
_) -> DType
ty_head
, DConT Name
data_tycon <- DType
data_ty_head
-> do let cls_pred :: DType
cls_pred = DType -> DCxt -> DType
foldType DType
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 DataFlavor
df DCxt
_ Name
dn [DTyVarBndrUnit]
dtvbs Maybe DType
dk [DCon]
dcons [DDerivClause]
_) Maybe [DDec]
_) -> do
[DTyVarBndrUnit]
all_tvbs <- [DTyVarBndrUnit] -> Maybe DType -> m [DTyVarBndrUnit]
forall (q :: * -> *).
DsMonad q =>
[DTyVarBndrUnit] -> Maybe DType -> q [DTyVarBndrUnit]
buildDataDTvbs [DTyVarBndrUnit]
dtvbs Maybe DType
dk
let data_decl :: DataDecl
data_decl = DataFlavor -> Name -> [DTyVarBndrUnit] -> [DCon] -> DataDecl
DataDecl DataFlavor
df Name
dn [DTyVarBndrUnit]
all_tvbs [DCon]
dcons
Maybe DDerivStrategy
-> DType -> Maybe DCxt -> DType -> DataDecl -> m PartitionedDecs
forall (m :: * -> *).
OptionsMonad m =>
Maybe DDerivStrategy
-> DType -> Maybe DCxt -> DType -> DataDecl -> m PartitionedDecs
partitionDeriving Maybe DDerivStrategy
mb_strat DType
cls_pred (DCxt -> Maybe DCxt
forall a. a -> Maybe a
Just DCxt
ctxt) DType
data_ty DataDecl
data_decl
Just DInfo
_ ->
String -> m PartitionedDecs
forall a. String -> m a
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]
++ DType -> String
forall a. Show a => a -> String
show DType
data_ty
Maybe DInfo
_ -> String -> m PartitionedDecs
forall a. String -> m a
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]
++ DType -> String
forall a. Show a => a -> String
show DType
data_ty
(DType, [DTypeArg])
_ -> PartitionedDecs -> m PartitionedDecs
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PartitionedDecs
forall a. Monoid a => a
mempty
partitionDec DDec
dec =
String -> m PartitionedDecs
forall a. String -> m a
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 :: forall (m :: * -> *).
MonadFail m =>
DDec -> m (ULetDecEnv, [OpenTypeFamilyDecl])
partitionClassDec (DLetDec (DSigD Name
name DType
ty)) =
(ULetDecEnv, [OpenTypeFamilyDecl])
-> m (ULetDecEnv, [OpenTypeFamilyDecl])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> DType -> ULetDecEnv
typeBinding Name
name DType
ty, [OpenTypeFamilyDecl]
forall a. Monoid a => a
mempty)
partitionClassDec (DLetDec (DValD (DVarP Name
name) DExp
exp)) =
(ULetDecEnv, [OpenTypeFamilyDecl])
-> m (ULetDecEnv, [OpenTypeFamilyDecl])
forall a. a -> m a
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 a. a -> m a
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 a. a -> m a
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 a. a -> m a
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) =
(ULetDecEnv, [OpenTypeFamilyDecl])
-> m (ULetDecEnv, [OpenTypeFamilyDecl])
forall a. a -> m a
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 {}) =
(ULetDecEnv, [OpenTypeFamilyDecl])
-> m (ULetDecEnv, [OpenTypeFamilyDecl])
forall a. a -> m a
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 a. String -> m a
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)
, OMap Name DType
)
partitionInstanceDec :: forall (m :: * -> *).
MonadFail m =>
DDec -> m (Maybe (Name, ULetDecRHS), OMap Name DType)
partitionInstanceDec (DLetDec (DValD (DVarP Name
name) DExp
exp)) =
(Maybe (Name, ULetDecRHS), OMap Name DType)
-> m (Maybe (Name, ULetDecRHS), OMap Name DType)
forall a. a -> m a
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 DType
forall a. Monoid a => a
mempty)
partitionInstanceDec (DLetDec (DFunD Name
name [DClause]
clauses)) =
(Maybe (Name, ULetDecRHS), OMap Name DType)
-> m (Maybe (Name, ULetDecRHS), OMap Name DType)
forall a. a -> m a
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 DType
forall a. Monoid a => a
mempty)
partitionInstanceDec (DLetDec (DSigD Name
name DType
ty)) =
(Maybe (Name, ULetDecRHS), OMap Name DType)
-> m (Maybe (Name, ULetDecRHS), OMap Name DType)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Name, ULetDecRHS)
forall a. Maybe a
Nothing, Name -> DType -> OMap Name DType
forall k v. k -> v -> OMap k v
OMap.singleton Name
name DType
ty)
partitionInstanceDec (DLetDec (DPragmaD {})) =
(Maybe (Name, ULetDecRHS), OMap Name DType)
-> m (Maybe (Name, ULetDecRHS), OMap Name DType)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Name, ULetDecRHS)
forall a. Maybe a
Nothing, OMap Name DType
forall a. Monoid a => a
mempty)
partitionInstanceDec (DTySynInstD {}) =
(Maybe (Name, ULetDecRHS), OMap Name DType)
-> m (Maybe (Name, ULetDecRHS), OMap Name DType)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Name, ULetDecRHS)
forall a. Maybe a
Nothing, OMap Name DType
forall a. Monoid a => a
mempty)
partitionInstanceDec DDec
_ =
String -> m (Maybe (Name, ULetDecRHS), OMap Name DType)
forall a. String -> m a
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
-> DPred
-> Maybe DCxt
-> DType
-> DataDecl
-> m PartitionedDecs
partitionDeriving :: forall (m :: * -> *).
OptionsMonad m =>
Maybe DDerivStrategy
-> DType -> Maybe DCxt -> DType -> DataDecl -> m PartitionedDecs
partitionDeriving Maybe DDerivStrategy
mb_strat DType
deriv_pred Maybe DCxt
mb_ctxt DType
ty DataDecl
data_decl =
case DType -> (DType, [DTypeArg])
unfoldDType DType
deriv_pred of
(DConT Name
deriv_name, [DTypeArg]
arg_tys)
| Just DDerivStrategy
DAnyclassStrategy <- Maybe DDerivStrategy
mb_strat
-> PartitionedDecs -> m PartitionedDecs
forall a. a -> m a
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 { id_cxt :: DCxt
id_cxt = DCxt -> Maybe DCxt -> DCxt
forall a. a -> Maybe a -> a
fromMaybe [] Maybe DCxt
mb_ctxt
, 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]
++ [DType
ty]
, id_sigs :: OMap Name DType
id_sigs = OMap Name DType
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-th`."
PartitionedDecs -> m PartitionedDecs
forall a. a -> m a
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-th`."
PartitionedDecs -> m PartitionedDecs
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PartitionedDecs
forall a. Monoid a => a
mempty
(DConT Name
deriv_name, [])
| 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
| 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-th` doesn't recognize the stock class "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
deriv_name
PartitionedDecs -> m PartitionedDecs
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PartitionedDecs
forall a. Monoid a => a
mempty
(DType, [DTypeArg])
_ -> PartitionedDecs -> m PartitionedDecs
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PartitionedDecs
forall a. Monoid a => a
mempty
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 DType
ty DataDecl
data_decl
mk_derived_inst :: UInstDecl -> PartitionedDecs
mk_derived_inst UInstDecl
dec = PartitionedDecs
forall a. Monoid a => a
mempty { pd_instance_decs = [dec] }
derived_decl :: DerivedDecl cls
derived_decl :: forall (cls :: * -> Constraint). DerivedDecl cls
derived_decl = DerivedDecl { ded_mb_cxt :: Maybe DCxt
ded_mb_cxt = Maybe DCxt
mb_ctxt
, ded_type :: DType
ded_type = DType
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 DType -> (DType, [DTypeArg])
unfoldDType DType
ty of
(DConT Name
tc, [DTypeArg]
_) -> Name
tc
(DType
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]
++ DType -> String
forall a. Show a => a -> String
show DType
t
stock_or_default :: Bool
stock_or_default = Maybe DDerivStrategy -> Bool
isStockOrDefault Maybe DDerivStrategy
mb_strat
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 )
, ( Name
eqName, do
UInstDecl
inst_for_promotion <- DerivDesc m -> m UInstDecl
mk_instance DerivDesc m
forall (q :: * -> *). DsMonad q => DerivDesc q
mkEqInstance
let inst_for_decide :: DerivedDecl cls
inst_for_decide = DerivedDecl cls
forall (cls :: * -> Constraint). DerivedDecl cls
derived_decl
PartitionedDecs -> m PartitionedDecs
forall a. a -> m a
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 = [inst_for_promotion]
, pd_derived_eq_decs = [inst_for_decide] } )
, ( Name
showName, do
UInstDecl
inst_for_promotion <- DerivDesc m -> m UInstDecl
mk_instance DerivDesc m
forall (q :: * -> *). OptionsMonad q => DerivDesc q
mkShowInstance
let inst_for_show :: DerivedDecl cls
inst_for_show = DerivedDecl cls
forall (cls :: * -> Constraint). DerivedDecl cls
derived_decl
PartitionedDecs -> m PartitionedDecs
forall a. a -> m a
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 = [inst_for_promotion]
, pd_derived_show_decs = [inst_for_show] } )
]
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