{-# LANGUAGE
DeriveFunctor
, DeriveFoldable
, TemplateHaskell
, TypeOperators
, CPP #-}
module Data.Label.Derive
(
mkLabel
, mkLabels
, mkLabelsNamed
, getLabel
, fclabels
, mkLabelsWith
, getLabelWith
, defaultNaming
)
where
import Control.Applicative
import Control.Arrow
import Control.Category
import Control.Monad
import Data.Char (toLower, toUpper)
#if MIN_VERSION_base(4,8,0)
import Data.Foldable (toList)
#else
import Data.Foldable (Foldable, toList)
#endif
import Data.Label.Point
import Data.List (groupBy, sortBy, delete, nub)
import Data.Maybe (fromMaybe)
import Data.Ord
#if MIN_VERSION_template_haskell(2,17,0)
import Language.Haskell.TH hiding (classP)
#elif MIN_VERSION_template_haskell(2,10,0)
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH hiding (classP, TyVarBndr)
#else
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH hiding (TyVarBndr)
#endif
import Prelude hiding ((.), id)
import qualified Data.Label.Mono as Mono
import qualified Data.Label.Poly as Poly
#if MIN_VERSION_template_haskell(2,17,0)
#else
data Specificity = SpecifiedSpec
type TyVarBndr a = TH.TyVarBndr
#endif
mkLabels :: [Name] -> Q [Dec]
mkLabels :: [Name] -> Q [Dec]
mkLabels = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec])
-> ([Name] -> Q [[Dec]]) -> [Name] -> Q [Dec]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((String -> String)
-> Bool -> Bool -> Bool -> Bool -> Name -> Q [Dec]
mkLabelsWith String -> String
defaultNaming Bool
True Bool
False Bool
False Bool
True)
mkLabel :: Name -> Q [Dec]
mkLabel :: Name -> Q [Dec]
mkLabel = [Name] -> Q [Dec]
mkLabels ([Name] -> Q [Dec]) -> (Name -> [Name]) -> Name -> Q [Dec]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return
mkLabelsNamed :: (String -> String) -> [Name] -> Q [Dec]
mkLabelsNamed :: (String -> String) -> [Name] -> Q [Dec]
mkLabelsNamed String -> String
mk = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec])
-> ([Name] -> Q [[Dec]]) -> [Name] -> Q [Dec]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((String -> String)
-> Bool -> Bool -> Bool -> Bool -> Name -> Q [Dec]
mkLabelsWith String -> String
mk Bool
True Bool
False Bool
False Bool
True)
getLabel :: Name -> Q Exp
getLabel :: Name -> Q Exp
getLabel = Bool -> Bool -> Bool -> Name -> Q Exp
getLabelWith Bool
True Bool
False Bool
False
getLabelWith
:: Bool
-> Bool
-> Bool
-> Name
-> Q Exp
getLabelWith :: Bool -> Bool -> Bool -> Name -> Q Exp
getLabelWith Bool
sigs Bool
concrete Bool
failing Name
name =
do Dec
dec <- Name -> Q Dec
reifyDec Name
name
[Label]
labels <- (String -> String) -> Bool -> Bool -> Dec -> Q [Label]
generateLabels String -> String
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id Bool
concrete Bool
failing Dec
dec
let bodies :: [Q Exp]
bodies = (Label -> Q Exp) -> [Label] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\(LabelExpr [TyVarBndr Specificity]
_ CxtQ
_ TypeQ
_ Q Exp
b) -> Q Exp
b) [Label]
labels
types :: [TypeQ]
types = (Label -> TypeQ) -> [Label] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(LabelExpr [TyVarBndr Specificity]
_ CxtQ
_ TypeQ
t Q Exp
_) -> TypeQ
t) [Label]
labels
context :: CxtQ
context = [CxtQ] -> CxtQ
forall a. [a] -> a
head ([CxtQ] -> CxtQ) -> [CxtQ] -> CxtQ
forall a b. (a -> b) -> a -> b
$ (Label -> CxtQ) -> [Label] -> [CxtQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(LabelExpr [TyVarBndr Specificity]
_ CxtQ
c TypeQ
_ Q Exp
_) -> CxtQ
c) [Label]
labels
vars :: [TyVarBndr Specificity]
vars = [[TyVarBndr Specificity]] -> [TyVarBndr Specificity]
forall a. [a] -> a
head ([[TyVarBndr Specificity]] -> [TyVarBndr Specificity])
-> [[TyVarBndr Specificity]] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> a -> b
$ (Label -> [TyVarBndr Specificity])
-> [Label] -> [[TyVarBndr Specificity]]
forall a b. (a -> b) -> [a] -> [b]
map (\(LabelExpr [TyVarBndr Specificity]
v CxtQ
_ TypeQ
_ Q Exp
_) -> [TyVarBndr Specificity]
v) [Label]
labels
case [Q Exp]
bodies of
[Q Exp
b] -> if Bool
sigs then Q Exp
b Q Exp -> TypeQ -> Q Exp
`sigE` [TyVarBndr Specificity] -> CxtQ -> TypeQ -> TypeQ
forallT [TyVarBndr Specificity]
vars CxtQ
context ([TypeQ] -> TypeQ
forall a. [a] -> a
head [TypeQ]
types) else Q Exp
b
[Q Exp]
_ -> if Bool
sigs
then [Q Exp] -> Q Exp
tupE [Q Exp]
bodies Q Exp -> TypeQ -> Q Exp
`sigE`
[TyVarBndr Specificity] -> CxtQ -> TypeQ -> TypeQ
forallT [TyVarBndr Specificity]
vars CxtQ
context ((TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Int -> TypeQ
tupleT ([Q Exp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Exp]
bodies)) [TypeQ]
types)
else [Q Exp] -> Q Exp
tupE [Q Exp]
bodies
mkLabelsWith
:: (String -> String)
-> Bool
-> Bool
-> Bool
-> Bool
-> Name
-> Q [Dec]
mkLabelsWith :: (String -> String)
-> Bool -> Bool -> Bool -> Bool -> Name -> Q [Dec]
mkLabelsWith String -> String
mk Bool
sigs Bool
concrete Bool
failing Bool
inl Name
name =
do Dec
dec <- Name -> Q Dec
reifyDec Name
name
(String -> String)
-> Bool -> Bool -> Bool -> Bool -> Dec -> Q [Dec]
mkLabelsWithForDec String -> String
mk Bool
sigs Bool
concrete Bool
failing Bool
inl Dec
dec
defaultNaming :: String -> String
defaultNaming :: String -> String
defaultNaming String
field =
case String
field of
Char
'_' : Char
c : String
rest -> Char -> Char
toLower Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest
Char
f : String
rest -> Char
'l' Char -> String -> String
forall a. a -> [a] -> [a]
: Char -> Char
toUpper Char
f Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest
String
n -> String -> String
forall a. String -> a
fclError (String
"Cannot derive label for record selector with name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n)
fclabels :: Q [Dec] -> Q [Dec]
fclabels :: Q [Dec] -> Q [Dec]
fclabels Q [Dec]
decls =
do [Dec]
ds <- Q [Dec]
decls
[[Dec]]
ls <- [Dec] -> (Dec -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Dec]
ds [Dec] -> (Dec -> [Dec]) -> [Dec]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Dec -> [Dec]
labels) ((String -> String)
-> Bool -> Bool -> Bool -> Bool -> Dec -> Q [Dec]
mkLabelsWithForDec String -> String
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id Bool
True Bool
False Bool
False Bool
False)
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Dec -> Dec
delabelize (Dec -> Dec) -> [Dec] -> [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Dec]
ds) [Dec] -> [[Dec]] -> [[Dec]]
forall a. a -> [a] -> [a]
: [[Dec]]
ls))
where
labels :: Dec -> [Dec]
labels :: Dec -> [Dec]
labels Dec
dec =
case Dec
dec of
DataD {} -> [Dec
dec]
NewtypeD {} -> [Dec
dec]
Dec
_ -> []
delabelize :: Dec -> Dec
delabelize :: Dec -> Dec
delabelize Dec
dec =
case Dec
dec of
#if MIN_VERSION_template_haskell(2,11,0)
DataD Cxt
ctx Name
nm [TyVarBndr Specificity]
vars Maybe Kind
mk [Con]
cs [DerivClause]
ns -> Cxt
-> Name
-> [TyVarBndr Specificity]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD Cxt
ctx Name
nm [TyVarBndr Specificity]
vars Maybe Kind
mk (Con -> Con
con (Con -> Con) -> [Con] -> [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con]
cs) [DerivClause]
ns
NewtypeD Cxt
ctx Name
nm [TyVarBndr Specificity]
vars Maybe Kind
mk Con
c [DerivClause]
ns -> Cxt
-> Name
-> [TyVarBndr Specificity]
-> Maybe Kind
-> Con
-> [DerivClause]
-> Dec
NewtypeD Cxt
ctx Name
nm [TyVarBndr Specificity]
vars Maybe Kind
mk (Con -> Con
con Con
c) [DerivClause]
ns
#else
DataD ctx nm vars cs ns -> DataD ctx nm vars (con <$> cs) ns
NewtypeD ctx nm vars c ns -> NewtypeD ctx nm vars (con c) ns
#endif
Dec
rest -> Dec
rest
where con :: Con -> Con
con (RecC Name
n [VarBangType]
vst) = Name -> [BangType] -> Con
NormalC Name
n ((VarBangType -> BangType) -> [VarBangType] -> [BangType]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_, Bang
s, Kind
t) -> (Bang
s, Kind
t)) [VarBangType]
vst)
#if MIN_VERSION_template_haskell(2,11,0)
con (RecGadtC [Name]
ns [VarBangType]
vst Kind
ty) = [Name] -> [BangType] -> Kind -> Con
GadtC [Name]
ns ((VarBangType -> BangType) -> [VarBangType] -> [BangType]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_, Bang
s, Kind
t) -> (Bang
s, Kind
t)) [VarBangType]
vst) Kind
ty
#endif
con Con
c = Con
c
data Label
= LabelDecl
Name
DecQ
[TyVarBndr Specificity]
CxtQ
TypeQ
ExpQ
| LabelExpr
[TyVarBndr Specificity]
CxtQ
TypeQ
ExpQ
data Field c = Field
(Maybe Name)
Bool
Type
c
deriving (Field c -> Field c -> Bool
(Field c -> Field c -> Bool)
-> (Field c -> Field c -> Bool) -> Eq (Field c)
forall c. Eq c => Field c -> Field c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Field c -> Field c -> Bool
$c/= :: forall c. Eq c => Field c -> Field c -> Bool
== :: Field c -> Field c -> Bool
$c== :: forall c. Eq c => Field c -> Field c -> Bool
Eq, a -> Field b -> Field a
(a -> b) -> Field a -> Field b
(forall a b. (a -> b) -> Field a -> Field b)
-> (forall a b. a -> Field b -> Field a) -> Functor Field
forall a b. a -> Field b -> Field a
forall a b. (a -> b) -> Field a -> Field b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Field b -> Field a
$c<$ :: forall a b. a -> Field b -> Field a
fmap :: (a -> b) -> Field a -> Field b
$cfmap :: forall a b. (a -> b) -> Field a -> Field b
Functor, Field a -> Bool
(a -> m) -> Field a -> m
(a -> b -> b) -> b -> Field a -> b
(forall m. Monoid m => Field m -> m)
-> (forall m a. Monoid m => (a -> m) -> Field a -> m)
-> (forall m a. Monoid m => (a -> m) -> Field a -> m)
-> (forall a b. (a -> b -> b) -> b -> Field a -> b)
-> (forall a b. (a -> b -> b) -> b -> Field a -> b)
-> (forall b a. (b -> a -> b) -> b -> Field a -> b)
-> (forall b a. (b -> a -> b) -> b -> Field a -> b)
-> (forall a. (a -> a -> a) -> Field a -> a)
-> (forall a. (a -> a -> a) -> Field a -> a)
-> (forall a. Field a -> [a])
-> (forall a. Field a -> Bool)
-> (forall a. Field a -> Int)
-> (forall a. Eq a => a -> Field a -> Bool)
-> (forall a. Ord a => Field a -> a)
-> (forall a. Ord a => Field a -> a)
-> (forall a. Num a => Field a -> a)
-> (forall a. Num a => Field a -> a)
-> Foldable Field
forall a. Eq a => a -> Field a -> Bool
forall a. Num a => Field a -> a
forall a. Ord a => Field a -> a
forall m. Monoid m => Field m -> m
forall a. Field a -> Bool
forall a. Field a -> Int
forall a. Field a -> [a]
forall a. (a -> a -> a) -> Field a -> a
forall m a. Monoid m => (a -> m) -> Field a -> m
forall b a. (b -> a -> b) -> b -> Field a -> b
forall a b. (a -> b -> b) -> b -> Field a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: Field a -> a
$cproduct :: forall a. Num a => Field a -> a
sum :: Field a -> a
$csum :: forall a. Num a => Field a -> a
minimum :: Field a -> a
$cminimum :: forall a. Ord a => Field a -> a
maximum :: Field a -> a
$cmaximum :: forall a. Ord a => Field a -> a
elem :: a -> Field a -> Bool
$celem :: forall a. Eq a => a -> Field a -> Bool
length :: Field a -> Int
$clength :: forall a. Field a -> Int
null :: Field a -> Bool
$cnull :: forall a. Field a -> Bool
toList :: Field a -> [a]
$ctoList :: forall a. Field a -> [a]
foldl1 :: (a -> a -> a) -> Field a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Field a -> a
foldr1 :: (a -> a -> a) -> Field a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Field a -> a
foldl' :: (b -> a -> b) -> b -> Field a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Field a -> b
foldl :: (b -> a -> b) -> b -> Field a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Field a -> b
foldr' :: (a -> b -> b) -> b -> Field a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Field a -> b
foldr :: (a -> b -> b) -> b -> Field a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Field a -> b
foldMap' :: (a -> m) -> Field a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Field a -> m
foldMap :: (a -> m) -> Field a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Field a -> m
fold :: Field m -> m
$cfold :: forall m. Monoid m => Field m -> m
Foldable)
type Subst = [(Type, Type)]
data Context = Context
Int
Name
Con
deriving (Context -> Context -> Bool
(Context -> Context -> Bool)
-> (Context -> Context -> Bool) -> Eq Context
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Context -> Context -> Bool
$c/= :: Context -> Context -> Bool
== :: Context -> Context -> Bool
$c== :: Context -> Context -> Bool
Eq, Int -> Context -> String -> String
[Context] -> String -> String
Context -> String
(Int -> Context -> String -> String)
-> (Context -> String)
-> ([Context] -> String -> String)
-> Show Context
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Context] -> String -> String
$cshowList :: [Context] -> String -> String
show :: Context -> String
$cshow :: Context -> String
showsPrec :: Int -> Context -> String -> String
$cshowsPrec :: Int -> Context -> String -> String
Show)
data Typing = Typing
Bool
TypeQ
TypeQ
[TyVarBndr Specificity]
mkLabelsWithForDec :: (String -> String) -> Bool -> Bool -> Bool -> Bool -> Dec -> Q [Dec]
mkLabelsWithForDec :: (String -> String)
-> Bool -> Bool -> Bool -> Bool -> Dec -> Q [Dec]
mkLabelsWithForDec String -> String
mk Bool
sigs Bool
concrete Bool
failing Bool
inl Dec
dec =
do [Label]
labels <- (String -> String) -> Bool -> Bool -> Dec -> Q [Label]
generateLabels String -> String
mk Bool
concrete Bool
failing Dec
dec
[[Dec]]
decls <- [Label] -> (Label -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Label]
labels ((Label -> Q [Dec]) -> Q [[Dec]])
-> (Label -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \Label
l ->
case Label
l of
LabelExpr {} -> [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
LabelDecl Name
n Q Dec
i [TyVarBndr Specificity]
v CxtQ
c TypeQ
t Q Exp
b ->
do [Dec]
bdy <- Dec -> [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [ClauseQ] -> Q Dec
funD Name
n [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (Q Exp -> BodyQ
normalB Q Exp
b) []]
[Dec]
prg <- if Bool
inl then Dec -> [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
i else [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
[Dec]
typ <- if Bool
sigs
then Dec -> [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TypeQ -> Q Dec
sigD Name
n ([TyVarBndr Specificity] -> CxtQ -> TypeQ -> TypeQ
forallT [TyVarBndr Specificity]
v CxtQ
c TypeQ
t)
else [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]
prg, [Dec]
typ, [Dec]
bdy])
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decls)
generateLabels :: (String -> String) -> Bool -> Bool -> Dec -> Q [Label]
generateLabels :: (String -> String) -> Bool -> Bool -> Dec -> Q [Label]
generateLabels String -> String
mk Bool
concrete Bool
failing Dec
dec =
do
let (Name
name, [Con]
cons, [TyVarBndr Specificity]
vars) =
case Dec
dec of
#if MIN_VERSION_template_haskell(2,11,0)
DataD Cxt
_ Name
n [TyVarBndr Specificity]
vs Maybe Kind
_ [Con]
cs [DerivClause]
_ -> (Name
n, [Con]
cs, [TyVarBndr Specificity]
vs)
NewtypeD Cxt
_ Name
n [TyVarBndr Specificity]
vs Maybe Kind
_ Con
c [DerivClause]
_ -> (Name
n, [Con
c], [TyVarBndr Specificity]
vs)
#else
DataD _ n vs cs _ -> (n, cs, vs)
NewtypeD _ n vs c _ -> (n, [c], vs)
#endif
Dec
_ -> String -> (Name, [Con], [TyVarBndr Specificity])
forall a. String -> a
fclError String
"Can only derive labels for datatypes and newtypes."
fields :: [Field ([Context], Subst)]
fields = (String -> String)
-> [TyVarBndr Specificity] -> [Con] -> [Field ([Context], Subst)]
forall a.
(String -> String)
-> [TyVarBndr Specificity] -> [Con] -> [Field ([Context], Subst)]
groupFields String -> String
mk [TyVarBndr Specificity]
vars [Con]
cons
[Field ([Context], Subst)]
-> (Field ([Context], Subst) -> Q Label) -> Q [Label]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Field ([Context], Subst)]
fields ((Field ([Context], Subst) -> Q Label) -> Q [Label])
-> (Field ([Context], Subst) -> Q Label) -> Q [Label]
forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Name
-> [TyVarBndr Specificity]
-> [Con]
-> Field ([Context], Subst)
-> Q Label
generateLabel Bool
failing Bool
concrete Name
name [TyVarBndr Specificity]
vars [Con]
cons
groupFields :: (String -> String) -> [TyVarBndr a] -> [Con]
-> [Field ([Context], Subst)]
groupFields :: (String -> String)
-> [TyVarBndr Specificity] -> [Con] -> [Field ([Context], Subst)]
groupFields String -> String
mk [TyVarBndr Specificity]
vs
= (Field ([Context], Subst) -> Field ([Context], Subst))
-> [Field ([Context], Subst)] -> [Field ([Context], Subst)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String)
-> Field ([Context], Subst) -> Field ([Context], Subst)
forall c. (String -> String) -> Field c -> Field c
rename String -> String
mk)
([Field ([Context], Subst)] -> [Field ([Context], Subst)])
-> ([Con] -> [Field ([Context], Subst)])
-> [Con]
-> [Field ([Context], Subst)]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ([Field (Context, Subst)] -> [Field ([Context], Subst)])
-> [[Field (Context, Subst)]] -> [Field ([Context], Subst)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\[Field (Context, Subst)]
fs -> let vals :: [(Context, Subst)]
vals = [[(Context, Subst)]] -> [(Context, Subst)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Field (Context, Subst) -> [(Context, Subst)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Field (Context, Subst) -> [(Context, Subst)])
-> [Field (Context, Subst)] -> [[(Context, Subst)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field (Context, Subst)]
fs)
cons :: [Context]
cons = (Context, Subst) -> Context
forall a b. (a, b) -> a
fst ((Context, Subst) -> Context) -> [(Context, Subst)] -> [Context]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Context, Subst)]
vals
subst :: Subst
subst = [Subst] -> Subst
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Context, Subst) -> Subst
forall a b. (a, b) -> b
snd ((Context, Subst) -> Subst) -> [(Context, Subst)] -> [Subst]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Context, Subst)]
vals)
in [Field ([Context], Subst)] -> [Field ([Context], Subst)]
forall a. Eq a => [a] -> [a]
nub (((Context, Subst) -> ([Context], Subst))
-> Field (Context, Subst) -> Field ([Context], Subst)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Context], Subst) -> (Context, Subst) -> ([Context], Subst)
forall a b. a -> b -> a
const ([Context]
cons, Subst
subst)) (Field (Context, Subst) -> Field ([Context], Subst))
-> [Field (Context, Subst)] -> [Field ([Context], Subst)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field (Context, Subst)]
fs)
)
([[Field (Context, Subst)]] -> [Field ([Context], Subst)])
-> ([Con] -> [[Field (Context, Subst)]])
-> [Con]
-> [Field ([Context], Subst)]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Field (Context, Subst) -> Field (Context, Subst) -> Bool)
-> [Field (Context, Subst)] -> [[Field (Context, Subst)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy Field (Context, Subst) -> Field (Context, Subst) -> Bool
forall c c. Field c -> Field c -> Bool
eq
([Field (Context, Subst)] -> [[Field (Context, Subst)]])
-> ([Con] -> [Field (Context, Subst)])
-> [Con]
-> [[Field (Context, Subst)]]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Field (Context, Subst) -> Field (Context, Subst) -> Ordering)
-> [Field (Context, Subst)] -> [Field (Context, Subst)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Field (Context, Subst) -> Maybe Name)
-> Field (Context, Subst) -> Field (Context, Subst) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Field (Context, Subst) -> Maybe Name
forall c. Field c -> Maybe Name
name)
([Field (Context, Subst)] -> [Field (Context, Subst)])
-> ([Con] -> [Field (Context, Subst)])
-> [Con]
-> [Field (Context, Subst)]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Con -> [Field (Context, Subst)])
-> [Con] -> [Field (Context, Subst)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([TyVarBndr Specificity] -> Con -> [Field (Context, Subst)]
forall a.
[TyVarBndr Specificity] -> Con -> [Field (Context, Subst)]
constructorFields [TyVarBndr Specificity]
vs)
where name :: Field c -> Maybe Name
name (Field Maybe Name
n Bool
_ Kind
_ c
_) = Maybe Name
n
eq :: Field c -> Field c -> Bool
eq Field c
f Field c
g = Bool
False Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
`fromMaybe` (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Name -> Name -> Bool) -> Maybe Name -> Maybe (Name -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Field c -> Maybe Name
forall c. Field c -> Maybe Name
name Field c
f Maybe (Name -> Bool) -> Maybe Name -> Maybe Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Field c -> Maybe Name
forall c. Field c -> Maybe Name
name Field c
g)
rename :: (String -> String) -> Field c -> Field c
rename String -> String
f (Field Maybe Name
n Bool
a Kind
b c
c) =
Maybe Name -> Bool -> Kind -> c -> Field c
forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field (String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> String
f (String -> String) -> (Name -> String) -> Name -> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> String
nameBase (Name -> Name) -> Maybe Name -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Name
n) Bool
a Kind
b c
c
constructorFields :: [TyVarBndr a] -> Con -> [Field (Context, Subst)]
constructorFields :: [TyVarBndr Specificity] -> Con -> [Field (Context, Subst)]
constructorFields [TyVarBndr Specificity]
vs Con
con =
case Con
con of
NormalC Name
c [BangType]
fs -> (Int, BangType) -> Field (Context, Subst)
forall a. (Int, BangType) -> Field (Context, [a])
one ((Int, BangType) -> Field (Context, Subst))
-> [(Int, BangType)] -> [Field (Context, Subst)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> [BangType] -> [(Int, BangType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [BangType]
fs
where one :: (Int, BangType) -> Field (Context, [a])
one (Int
i, f :: BangType
f@(Bang
_, Kind
ty)) = Maybe Name
-> Bool -> Kind -> (Context, [a]) -> Field (Context, [a])
forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field Maybe Name
forall a. Maybe a
Nothing Bool
mono Kind
ty (Int -> Name -> Con -> Context
Context Int
i Name
c Con
con, [])
where fsTys :: [[Name]]
fsTys = (BangType -> [Name]) -> [BangType] -> [[Name]]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> [Name]
typeVariables (Kind -> [Name]) -> (BangType -> Kind) -> BangType -> [Name]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. BangType -> Kind
forall a b. (a, b) -> b
snd) (BangType -> [BangType] -> [BangType]
forall a. Eq a => a -> [a] -> [a]
delete BangType
f [BangType]
fs)
mono :: Bool
mono = (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
x -> ([Name] -> Bool) -> [[Name]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Name
x) [[Name]]
fsTys) (Kind -> [Name]
typeVariables Kind
ty)
RecC Name
c [VarBangType]
fs -> (Int, VarBangType) -> Field (Context, Subst)
forall a. (Int, VarBangType) -> Field (Context, [a])
one ((Int, VarBangType) -> Field (Context, Subst))
-> [(Int, VarBangType)] -> [Field (Context, Subst)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> [VarBangType] -> [(Int, VarBangType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [VarBangType]
fs
where one :: (Int, VarBangType) -> Field (Context, [a])
one (Int
i, f :: VarBangType
f@(Name
n, Bang
_, Kind
ty)) = Maybe Name
-> Bool -> Kind -> (Context, [a]) -> Field (Context, [a])
forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n) Bool
mono Kind
ty (Int -> Name -> Con -> Context
Context Int
i Name
c Con
con, [])
where fsTys :: [[Name]]
fsTys = (VarBangType -> [Name]) -> [VarBangType] -> [[Name]]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> [Name]
typeVariables (Kind -> [Name]) -> (VarBangType -> Kind) -> VarBangType -> [Name]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. VarBangType -> Kind
forall a b c. (a, b, c) -> c
trd) (VarBangType -> [VarBangType] -> [VarBangType]
forall a. Eq a => a -> [a] -> [a]
delete VarBangType
f [VarBangType]
fs)
mono :: Bool
mono = (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
x -> ([Name] -> Bool) -> [[Name]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Name
x) [[Name]]
fsTys) (Kind -> [Name]
typeVariables Kind
ty)
InfixC BangType
a Name
c BangType
b -> (Int, BangType) -> Field (Context, Subst)
forall a a. (Int, (a, Kind)) -> Field (Context, [a])
one ((Int, BangType) -> Field (Context, Subst))
-> [(Int, BangType)] -> [Field (Context, Subst)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int
0, BangType
a), (Int
1, BangType
b)]
where one :: (Int, (a, Kind)) -> Field (Context, [a])
one (Int
i, (a
_, Kind
ty)) = Maybe Name
-> Bool -> Kind -> (Context, [a]) -> Field (Context, [a])
forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field Maybe Name
forall a. Maybe a
Nothing Bool
mono Kind
ty (Int -> Name -> Con -> Context
Context Int
i Name
c Con
con, [])
where fsTys :: [[Name]]
fsTys = (BangType -> [Name]) -> [BangType] -> [[Name]]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> [Name]
typeVariables (Kind -> [Name]) -> (BangType -> Kind) -> BangType -> [Name]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. BangType -> Kind
forall a b. (a, b) -> b
snd) [BangType
a, BangType
b]
mono :: Bool
mono = (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
x -> ([Name] -> Bool) -> [[Name]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Name
x) [[Name]]
fsTys) (Kind -> [Name]
typeVariables Kind
ty)
ForallC [TyVarBndr Specificity]
x Cxt
y Con
v -> Field (Context, Subst) -> Field (Context, Subst)
setEqs (Field (Context, Subst) -> Field (Context, Subst))
-> [Field (Context, Subst)] -> [Field (Context, Subst)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr Specificity] -> Con -> [Field (Context, Subst)]
forall a.
[TyVarBndr Specificity] -> Con -> [Field (Context, Subst)]
constructorFields [TyVarBndr Specificity]
vs Con
v
#if MIN_VERSION_template_haskell(2,10,0)
where eqs :: Subst
eqs = [ (Kind
a, Kind
b) | AppT (AppT Kind
EqualityT Kind
a) Kind
b <- Cxt
y ]
#else
where eqs = [ (a, b) | EqualP a b <- y ]
#endif
setEqs :: Field (Context, Subst) -> Field (Context, Subst)
setEqs (Field Maybe Name
a Bool
b Kind
c (Context, Subst)
d) = Maybe Name
-> Bool -> Kind -> (Context, Subst) -> Field (Context, Subst)
forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field Maybe Name
a Bool
b Kind
c ((Context -> Context) -> (Context, Subst) -> (Context, Subst)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Context -> Context
upd ((Context, Subst) -> (Context, Subst))
-> ((Context, Subst) -> (Context, Subst))
-> (Context, Subst)
-> (Context, Subst)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Subst -> Subst) -> (Context, Subst) -> (Context, Subst)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Subst
eqs Subst -> Subst -> Subst
forall a. [a] -> [a] -> [a]
++) ((Context, Subst) -> (Context, Subst))
-> (Context, Subst) -> (Context, Subst)
forall a b. (a -> b) -> a -> b
$ (Context, Subst)
d)
upd :: Context -> Context
upd (Context Int
a Name
b Con
c) = Int -> Name -> Con -> Context
Context Int
a Name
b ([TyVarBndr Specificity] -> Cxt -> Con -> Con
ForallC [TyVarBndr Specificity]
x Cxt
y Con
c)
#if MIN_VERSION_template_haskell(2,11,0)
GadtC [Name]
cs [BangType]
fs Kind
resTy -> (Name -> [Field (Context, Subst)])
-> [Name] -> [Field (Context, Subst)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Name
c -> Name -> (Int, BangType) -> Field (Context, Subst)
one Name
c ((Int, BangType) -> Field (Context, Subst))
-> [(Int, BangType)] -> [Field (Context, Subst)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> [BangType] -> [(Int, BangType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [BangType]
fs) [Name]
cs
where one :: Name -> (Int, BangType) -> Field (Context, Subst)
one Name
c (Int
i, f :: BangType
f@(Bang
_, Kind
ty)) = Maybe Name
-> Bool -> Kind -> (Context, Subst) -> Field (Context, Subst)
forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field Maybe Name
forall a. Maybe a
Nothing Bool
mono Kind
ty (Int -> Name -> Con -> Context
Context Int
i Name
c Con
con, [TyVarBndr Specificity] -> Kind -> Subst
forall a. [TyVarBndr Specificity] -> Kind -> Subst
mkSubst [TyVarBndr Specificity]
vs Kind
resTy)
where fsTys :: [[Name]]
fsTys = (BangType -> [Name]) -> [BangType] -> [[Name]]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> [Name]
typeVariables (Kind -> [Name]) -> (BangType -> Kind) -> BangType -> [Name]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. BangType -> Kind
forall a b. (a, b) -> b
snd) (BangType -> [BangType] -> [BangType]
forall a. Eq a => a -> [a] -> [a]
delete BangType
f [BangType]
fs)
mono :: Bool
mono = (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
x -> ([Name] -> Bool) -> [[Name]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Name
x) [[Name]]
fsTys) (Kind -> [Name]
typeVariables Kind
ty)
RecGadtC [Name]
cs [VarBangType]
fs Kind
resTy -> (Name -> [Field (Context, Subst)])
-> [Name] -> [Field (Context, Subst)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Name
c -> Name -> (Int, VarBangType) -> Field (Context, Subst)
one Name
c ((Int, VarBangType) -> Field (Context, Subst))
-> [(Int, VarBangType)] -> [Field (Context, Subst)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> [VarBangType] -> [(Int, VarBangType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [VarBangType]
fs) [Name]
cs
where one :: Name -> (Int, VarBangType) -> Field (Context, Subst)
one Name
c (Int
i, f :: VarBangType
f@(Name
n, Bang
_, Kind
ty)) = Maybe Name
-> Bool -> Kind -> (Context, Subst) -> Field (Context, Subst)
forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n) Bool
mono Kind
ty (Int -> Name -> Con -> Context
Context Int
i Name
c Con
con, [TyVarBndr Specificity] -> Kind -> Subst
forall a. [TyVarBndr Specificity] -> Kind -> Subst
mkSubst [TyVarBndr Specificity]
vs Kind
resTy)
where fsTys :: [[Name]]
fsTys = (VarBangType -> [Name]) -> [VarBangType] -> [[Name]]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> [Name]
typeVariables (Kind -> [Name]) -> (VarBangType -> Kind) -> VarBangType -> [Name]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. VarBangType -> Kind
forall a b c. (a, b, c) -> c
trd) (VarBangType -> [VarBangType] -> [VarBangType]
forall a. Eq a => a -> [a] -> [a]
delete VarBangType
f [VarBangType]
fs)
mono :: Bool
mono = (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
x -> ([Name] -> Bool) -> [[Name]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Name
x) [[Name]]
fsTys) (Kind -> [Name]
typeVariables Kind
ty)
mkSubst :: [TyVarBndr a] -> Type -> Subst
mkSubst :: [TyVarBndr Specificity] -> Kind -> Subst
mkSubst [TyVarBndr Specificity]
vars Kind
t = [TyVarBndr Specificity] -> Kind -> Subst
forall a. [TyVarBndr Specificity] -> Kind -> Subst
go ([TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. [a] -> [a]
reverse [TyVarBndr Specificity]
vars) Kind
t
where
go :: [TyVarBndr Specificity] -> Kind -> Subst
go [] Kind
_ = []
go (TyVarBndr Specificity
v:[TyVarBndr Specificity]
vs) (AppT Kind
t1 Kind
t2) = (TyVarBndr Specificity -> Kind
forall a. TyVarBndr Specificity -> Kind
typeFromBinder TyVarBndr Specificity
v, Kind
t2) (Kind, Kind) -> Subst -> Subst
forall a. a -> [a] -> [a]
: [TyVarBndr Specificity] -> Kind -> Subst
go [TyVarBndr Specificity]
vs Kind
t1
go [TyVarBndr Specificity]
_ Kind
_ = String -> Subst
forall a. String -> a
fclError String
"Non-AppT with type variables in mkSubst. Please report this as a bug for fclabels."
#endif
prune :: [Context] -> [Con] -> [Con]
prune :: [Context] -> [Con] -> [Con]
prune [Context]
contexts [Con]
allCons =
case [Context]
contexts of
(Context Int
_ Name
_ Con
con) : [Context]
_
-> (Con -> Bool) -> [Con] -> [Con]
forall a. (a -> Bool) -> [a] -> [a]
filter (Con -> Con -> Bool
unifiableCon Con
con) [Con]
allCons
[] -> []
unifiableCon :: Con -> Con -> Bool
unifiableCon :: Con -> Con -> Bool
unifiableCon Con
a Con
b = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Kind -> Kind -> Bool) -> Cxt -> Cxt -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Kind -> Kind -> Bool
unifiable (Con -> Cxt
indices Con
a) (Con -> Cxt
indices Con
b))
where indices :: Con -> Cxt
indices Con
con =
case Con
con of
NormalC {} -> []
RecC {} -> []
InfixC {} -> []
#if MIN_VERSION_template_haskell(2,11,0)
ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
ty -> Con -> Cxt
indices Con
ty
#elif MIN_VERSION_template_haskell(2,10,0)
ForallC _ x _ -> [ c | AppT (AppT EqualityT _) c <- x ]
#else
ForallC _ x _ -> [ c | EqualP _ c <- x ]
#endif
#if MIN_VERSION_template_haskell(2,11,0)
GadtC [Name]
_ [BangType]
_ Kind
ty -> Kind -> Cxt
conIndices Kind
ty
RecGadtC [Name]
_ [VarBangType]
_ Kind
ty -> Kind -> Cxt
conIndices Kind
ty
where
conIndices :: Kind -> Cxt
conIndices (AppT (ConT Name
_) Kind
ty) = [Kind
ty]
conIndices (AppT Kind
rest Kind
ty) = Kind -> Cxt
conIndices Kind
rest Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ [Kind
ty]
conIndices Kind
_ = String -> Cxt
forall a. String -> a
fclError String
"Non-AppT in conIndices. Please report this as a bug for fclabels."
#endif
unifiable :: Type -> Type -> Bool
unifiable :: Kind -> Kind -> Bool
unifiable Kind
x Kind
y =
case (Kind
x, Kind
y) of
( VarT Name
_ , Kind
_ ) -> Bool
True
( Kind
_ , VarT Name
_ ) -> Bool
True
( AppT Kind
a Kind
b , AppT Kind
c Kind
d ) -> Kind -> Kind -> Bool
unifiable Kind
a Kind
c Bool -> Bool -> Bool
&& Kind -> Kind -> Bool
unifiable Kind
b Kind
d
( SigT Kind
t Kind
k , SigT Kind
s Kind
j ) -> Kind -> Kind -> Bool
unifiable Kind
t Kind
s Bool -> Bool -> Bool
&& Kind
k Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
j
( ForallT [TyVarBndr Specificity]
_ Cxt
_ Kind
t , ForallT [TyVarBndr Specificity]
_ Cxt
_ Kind
s ) -> Kind -> Kind -> Bool
unifiable Kind
t Kind
s
( Kind
a , Kind
b ) -> Kind
a Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
b
generateLabel
:: Bool
-> Bool
-> Name
-> [TyVarBndr ()]
-> [Con]
-> Field ([Context], Subst)
-> Q Label
generateLabel :: Bool
-> Bool
-> Name
-> [TyVarBndr Specificity]
-> [Con]
-> Field ([Context], Subst)
-> Q Label
generateLabel Bool
failing Bool
concrete Name
datatype [TyVarBndr Specificity]
dtVars [Con]
allCons
field :: Field ([Context], Subst)
field@(Field Maybe Name
name Bool
forcedMono Kind
fieldtype ([Context]
contexts, Subst
subst)) =
do let total :: Bool
total = [Context] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Context]
contexts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Con] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Context] -> [Con] -> [Con]
prune [Context]
contexts [Con]
allCons)
(Typing Bool
mono TypeQ
tyI TypeQ
tyO [TyVarBndr Specificity]
_)
<- Bool
-> Kind -> Name -> [TyVarBndr Specificity] -> Subst -> Q Typing
computeTypes Bool
forcedMono Kind
fieldtype Name
datatype [TyVarBndr Specificity]
dtVars Subst
subst
let cat :: TypeQ
cat = Name -> TypeQ
varT (String -> Name
mkName String
"cat")
failE :: Q Exp
failE = if Bool
failing
then [| failArrow |]
else [| zeroArrow |]
getT :: Q Exp
getT = [| arr $(getter failing total field) |]
putT :: Q Exp
putT = [| arr $(setter failing total field) |]
getP :: Q Exp
getP = [| $(failE) ||| id <<< $getT |]
putP :: Q Exp
putP = [| $(failE) ||| id <<< $putT |]
failP :: TypeQ
failP = if Bool
failing
then Name -> [TypeQ] -> TypeQ
classP ''ArrowFail [ [t| String |], TypeQ
cat]
else Name -> [TypeQ] -> TypeQ
classP ''ArrowZero [TypeQ
cat]
ctx :: CxtQ
ctx = if Bool
total
then [TypeQ] -> CxtQ
cxt [ Name -> [TypeQ] -> TypeQ
classP ''ArrowApply [TypeQ
cat] ]
else [TypeQ] -> CxtQ
cxt [ Name -> [TypeQ] -> TypeQ
classP ''ArrowChoice [TypeQ
cat]
, Name -> [TypeQ] -> TypeQ
classP ''ArrowApply [TypeQ
cat]
, TypeQ
failP
]
body :: Q Exp
body = if Bool
total
then [| Poly.point $ Point $getT (modifier $getT $putT) |]
else [| Poly.point $ Point $getP (modifier $getP $putP) |]
cont :: CxtQ
cont = if Bool
concrete
then [TypeQ] -> CxtQ
cxt []
else CxtQ
ctx
partial :: TypeQ
partial = if Bool
failing
then [t| Failing String |]
else [t| Partial |]
concTy :: TypeQ
concTy = if Bool
total
then if Bool
mono
then [t| Mono.Lens Total $tyI $tyO |]
else [t| Poly.Lens Total $tyI $tyO |]
else if Bool
mono
then [t| Mono.Lens $partial $tyI $tyO |]
else [t| Poly.Lens $partial $tyI $tyO |]
ty :: TypeQ
ty = if Bool
concrete
then TypeQ
concTy
else if Bool
mono
then [t| Mono.Lens $cat $tyI $tyO |]
else [t| Poly.Lens $cat $tyI $tyO |]
[TyVarBndr Specificity]
tvs <- [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. Eq a => [a] -> [a]
nub ([TyVarBndr Specificity] -> [TyVarBndr Specificity])
-> (Kind -> [TyVarBndr Specificity])
-> Kind
-> [TyVarBndr Specificity]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Kind -> [TyVarBndr Specificity]
binderFromType (Kind -> [TyVarBndr Specificity])
-> TypeQ -> Q [TyVarBndr Specificity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ
ty
Label -> Q Label
forall (m :: * -> *) a. Monad m => a -> m a
return (Label -> Q Label) -> Label -> Q Label
forall a b. (a -> b) -> a -> b
$
case Maybe Name
name of
Maybe Name
Nothing -> [TyVarBndr Specificity] -> CxtQ -> TypeQ -> Q Exp -> Label
LabelExpr [TyVarBndr Specificity]
tvs CxtQ
cont TypeQ
ty Q Exp
body
Just Name
n ->
#if MIN_VERSION_template_haskell(2,8,0)
let inline :: Pragma
inline = Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
n Inline
Inline RuleMatch
FunLike (Int -> Phases
FromPhase Int
0)
#else
let inline = InlineP n (InlineSpec True True (Just (True, 0)))
#endif
in Name
-> Q Dec
-> [TyVarBndr Specificity]
-> CxtQ
-> TypeQ
-> Q Exp
-> Label
LabelDecl Name
n (Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma -> Dec
PragmaD Pragma
inline)) [TyVarBndr Specificity]
tvs CxtQ
cont TypeQ
ty Q Exp
body
modifier :: ArrowApply cat => cat f o -> cat (i, f) g -> cat (cat o i, f) g
modifier :: cat f o -> cat (i, f) g -> cat (cat o i, f) g
modifier cat f o
g cat (i, f) g
m = cat (i, f) g
m cat (i, f) g -> cat (cat o i, f) (i, f) -> cat (cat o i, f) g
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. cat (cat o i, o) i -> cat ((cat o i, o), f) (i, f)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first cat (cat o i, o) i
forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app cat ((cat o i, o), f) (i, f)
-> cat (cat o i, f) ((cat o i, o), f) -> cat (cat o i, f) (i, f)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((cat o i, (f, o)) -> ((cat o i, o), f))
-> cat (cat o i, (f, o)) ((cat o i, o), f)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(cat o i
n, (f
f, o
o)) -> ((cat o i
n, o
o), f
f)) cat (cat o i, (f, o)) ((cat o i, o), f)
-> cat (cat o i, f) (cat o i, (f, o))
-> cat (cat o i, f) ((cat o i, o), f)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. cat f (f, o) -> cat (cat o i, f) (cat o i, (f, o))
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (cat f f
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id cat f f -> cat f o -> cat f (f, o)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& cat f o
g)
{-# INLINE modifier #-}
getter :: Bool -> Bool -> Field ([Context], Subst) -> Q Exp
getter :: Bool -> Bool -> Field ([Context], Subst) -> Q Exp
getter Bool
failing Bool
total (Field Maybe Name
mn Bool
_ Kind
_ ([Context]
cons, Subst
_)) =
do let pt :: Name
pt = String -> Name
mkName String
"f"
nm :: Q Exp
nm = Q Exp -> (Name -> Q Exp) -> Maybe Name -> Q Exp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Q Exp] -> Q Exp
tupE []) (Lit -> Q Exp
litE (Lit -> Q Exp) -> (Name -> Lit) -> Name -> Q Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Lit
StringL (String -> Lit) -> (Name -> String) -> Name -> Lit
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> String
nameBase) (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
failing Maybe () -> Maybe Name -> Maybe Name
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Name
mn)
wild :: [MatchQ]
wild = if Bool
total then [] else [PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
wildP (Q Exp -> BodyQ
normalB [| Left $(nm) |]) []]
rght :: Q Exp -> Q Exp
rght = if Bool
total then Q Exp -> Q Exp
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id else Q Exp -> Q Exp -> Q Exp
appE [| Right |]
mkCase :: Context -> [MatchQ]
mkCase (Context Int
i Name
_ Con
c) = ((PatQ, Q Exp) -> MatchQ) -> [(PatQ, Q Exp)] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(PatQ
pat, Q Exp
var) -> PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
pat (Q Exp -> BodyQ
normalB (Q Exp -> Q Exp
rght Q Exp
var)) []) (Int -> Con -> [(PatQ, Q Exp)]
case1 Int
i Con
c)
[PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
pt]
(Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
pt) ((Context -> [MatchQ]) -> [Context] -> [MatchQ]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Context -> [MatchQ]
mkCase [Context]
cons [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. [a] -> [a] -> [a]
++ [MatchQ]
wild))
where
case1 :: Int -> Con -> [(Q Pat, Q Exp)]
case1 :: Int -> Con -> [(PatQ, Q Exp)]
case1 Int
i Con
con =
case Con
con of
NormalC Name
c [BangType]
fs -> [[BangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [BangType]
fs Name
c]
RecC Name
c [VarBangType]
fs -> [[VarBangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [VarBangType]
fs Name
c]
InfixC BangType
_ Name
c BangType
_ -> [(PatQ -> Name -> PatQ -> PatQ
infixP ([PatQ]
pats [PatQ] -> Int -> PatQ
forall a. [a] -> Int -> a
!! Int
0) Name
c ([PatQ]
pats [PatQ] -> Int -> PatQ
forall a. [a] -> Int -> a
!! Int
1), Q Exp
var)]
ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
c -> Int -> Con -> [(PatQ, Q Exp)]
case1 Int
i Con
c
#if MIN_VERSION_template_haskell(2,11,0)
GadtC [Name]
cs [BangType]
fs Kind
_ -> (Name -> (PatQ, Q Exp)) -> [Name] -> [(PatQ, Q Exp)]
forall a b. (a -> b) -> [a] -> [b]
map ([BangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [BangType]
fs) [Name]
cs
RecGadtC [Name]
cs [VarBangType]
fs Kind
_ -> (Name -> (PatQ, Q Exp)) -> [Name] -> [(PatQ, Q Exp)]
forall a b. (a -> b) -> [a] -> [b]
map ([VarBangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [VarBangType]
fs) [Name]
cs
#endif
where fresh :: [Name]
fresh = String -> Name
mkName (String -> Name) -> [String] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> [String]
forall a. Eq a => a -> [a] -> [a]
delete String
"f" [String]
freshNames
pats1 :: [PatQ]
pats1 = Name -> PatQ
varP (Name -> PatQ) -> [Name] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fresh
pats :: [PatQ]
pats = Int -> PatQ -> [PatQ]
forall a. Int -> a -> [a]
replicate Int
i PatQ
wildP [PatQ] -> [PatQ] -> [PatQ]
forall a. [a] -> [a] -> [a]
++ [[PatQ]
pats1 [PatQ] -> Int -> PatQ
forall a. [a] -> Int -> a
!! Int
i] [PatQ] -> [PatQ] -> [PatQ]
forall a. [a] -> [a] -> [a]
++ PatQ -> [PatQ]
forall a. a -> [a]
repeat PatQ
wildP
var :: Q Exp
var = Name -> Q Exp
varE ([Name]
fresh [Name] -> Int -> Name
forall a. [a] -> Int -> a
!! Int
i)
one :: t a -> Name -> (PatQ, Q Exp)
one t a
fs Name
c = let s :: [a] -> [a]
s = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
fs) in (Name -> [PatQ] -> PatQ
conP Name
c ([PatQ] -> [PatQ]
forall a. [a] -> [a]
s [PatQ]
pats), Q Exp
var)
setter :: Bool -> Bool -> Field ([Context], Subst) -> Q Exp
setter :: Bool -> Bool -> Field ([Context], Subst) -> Q Exp
setter Bool
failing Bool
total (Field Maybe Name
mn Bool
_ Kind
_ ([Context]
cons, Subst
_)) =
do let pt :: Name
pt = String -> Name
mkName String
"f"
md :: Name
md = String -> Name
mkName String
"v"
nm :: Q Exp
nm = Q Exp -> (Name -> Q Exp) -> Maybe Name -> Q Exp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Q Exp] -> Q Exp
tupE []) (Lit -> Q Exp
litE (Lit -> Q Exp) -> (Name -> Lit) -> Name -> Q Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Lit
StringL (String -> Lit) -> (Name -> String) -> Name -> Lit
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> String
nameBase) (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
failing Maybe () -> Maybe Name -> Maybe Name
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Name
mn)
wild :: [MatchQ]
wild = if Bool
total then [] else [PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
wildP (Q Exp -> BodyQ
normalB [| Left $(nm) |]) []]
rght :: Q Exp -> Q Exp
rght = if Bool
total then Q Exp -> Q Exp
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id else Q Exp -> Q Exp -> Q Exp
appE [| Right |]
mkCase :: Context -> [MatchQ]
mkCase (Context Int
i Name
_ Con
c) = ((PatQ, Q Exp) -> MatchQ) -> [(PatQ, Q Exp)] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(PatQ
pat, Q Exp
var) -> PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
pat (Q Exp -> BodyQ
normalB (Q Exp -> Q Exp
rght Q Exp
var)) []) (Int -> Con -> [(PatQ, Q Exp)]
case1 Int
i Con
c)
[PatQ] -> Q Exp -> Q Exp
lamE [[PatQ] -> PatQ
tupP [Name -> PatQ
varP Name
md, Name -> PatQ
varP Name
pt]]
(Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
pt) ((Context -> [MatchQ]) -> [Context] -> [MatchQ]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Context -> [MatchQ]
mkCase [Context]
cons [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. [a] -> [a] -> [a]
++ [MatchQ]
wild))
where
case1 :: Int -> Con -> [(PatQ, Q Exp)]
case1 Int
i Con
con =
case Con
con of
NormalC Name
c [BangType]
fs -> [[BangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [BangType]
fs Name
c]
RecC Name
c [VarBangType]
fs -> [[VarBangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [VarBangType]
fs Name
c]
InfixC BangType
_ Name
c BangType
_ -> [( PatQ -> Name -> PatQ -> PatQ
infixP ([PatQ]
pats [PatQ] -> Int -> PatQ
forall a. [a] -> Int -> a
!! Int
0) Name
c ([PatQ]
pats [PatQ] -> Int -> PatQ
forall a. [a] -> Int -> a
!! Int
1)
, Maybe (Q Exp) -> Q Exp -> Maybe (Q Exp) -> Q Exp
infixE (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just ([Q Exp]
vars [Q Exp] -> Int -> Q Exp
forall a. [a] -> Int -> a
!! Int
0)) (Name -> Q Exp
conE Name
c) (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just ([Q Exp]
vars [Q Exp] -> Int -> Q Exp
forall a. [a] -> Int -> a
!! Int
1))
)
]
ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
c -> Int -> Con -> [(PatQ, Q Exp)]
case1 Int
i Con
c
#if MIN_VERSION_template_haskell(2,11,0)
GadtC [Name]
cs [BangType]
fs Kind
_ -> (Name -> (PatQ, Q Exp)) -> [Name] -> [(PatQ, Q Exp)]
forall a b. (a -> b) -> [a] -> [b]
map ([BangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [BangType]
fs) [Name]
cs
RecGadtC [Name]
cs [VarBangType]
fs Kind
_ -> (Name -> (PatQ, Q Exp)) -> [Name] -> [(PatQ, Q Exp)]
forall a b. (a -> b) -> [a] -> [b]
map ([VarBangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [VarBangType]
fs) [Name]
cs
#endif
where fresh :: [Name]
fresh = String -> Name
mkName (String -> Name) -> [String] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> [String]
forall a. Eq a => a -> [a] -> [a]
delete String
"f" (String -> [String] -> [String]
forall a. Eq a => a -> [a] -> [a]
delete String
"v" [String]
freshNames)
pats1 :: [PatQ]
pats1 = Name -> PatQ
varP (Name -> PatQ) -> [Name] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fresh
pats :: [PatQ]
pats = Int -> [PatQ] -> [PatQ]
forall a. Int -> [a] -> [a]
take Int
i [PatQ]
pats1 [PatQ] -> [PatQ] -> [PatQ]
forall a. [a] -> [a] -> [a]
++ [PatQ
wildP] [PatQ] -> [PatQ] -> [PatQ]
forall a. [a] -> [a] -> [a]
++ Int -> [PatQ] -> [PatQ]
forall a. Int -> [a] -> [a]
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [PatQ]
pats1
vars1 :: [Q Exp]
vars1 = Name -> Q Exp
varE (Name -> Q Exp) -> [Name] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fresh
v :: Q Exp
v = Name -> Q Exp
varE (String -> Name
mkName String
"v")
vars :: [Q Exp]
vars = Int -> [Q Exp] -> [Q Exp]
forall a. Int -> [a] -> [a]
take Int
i [Q Exp]
vars1 [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ [Q Exp
v] [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ Int -> [Q Exp] -> [Q Exp]
forall a. Int -> [a] -> [a]
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Q Exp]
vars1
apps :: Q Exp -> t (Q Exp) -> Q Exp
apps Q Exp
f t (Q Exp)
as = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> t (Q Exp) -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
appE Q Exp
f t (Q Exp)
as
one :: t a -> Name -> (PatQ, Q Exp)
one t a
fs Name
c = let s :: [a] -> [a]
s = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
fs) in (Name -> [PatQ] -> PatQ
conP Name
c ([PatQ] -> [PatQ]
forall a. [a] -> [a]
s [PatQ]
pats), Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *). Foldable t => Q Exp -> t (Q Exp) -> Q Exp
apps (Name -> Q Exp
conE Name
c) ([Q Exp] -> [Q Exp]
forall a. [a] -> [a]
s [Q Exp]
vars))
freshNames :: [String]
freshNames :: [String]
freshNames = (Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char
'a'..Char
'z'] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Integer -> String) -> [Integer] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char
'a'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Integer -> String) -> Integer -> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Integer -> String
forall a. Show a => a -> String
show) [Integer
0 :: Integer ..]
computeTypes :: Bool -> Type -> Name -> [TyVarBndr ()] -> Subst -> Q Typing
computeTypes :: Bool
-> Kind -> Name -> [TyVarBndr Specificity] -> Subst -> Q Typing
computeTypes Bool
forcedMono Kind
fieldtype Name
datatype [TyVarBndr Specificity]
dtVars_ Subst
subst =
do let fieldVars :: [Name]
fieldVars = Kind -> [Name]
typeVariables Kind
fieldtype
tyO :: TypeQ
tyO = Kind -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
fieldtype
dtTypes :: Cxt
dtTypes = Subst -> Kind -> Kind
substitute Subst
subst (Kind -> Kind)
-> (TyVarBndr Specificity -> Kind) -> TyVarBndr Specificity -> Kind
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TyVarBndr Specificity -> Kind
forall a. TyVarBndr Specificity -> Kind
typeFromBinder (TyVarBndr Specificity -> Kind) -> [TyVarBndr Specificity] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr Specificity]
dtVars_
dtBinders :: [TyVarBndr Specificity]
dtBinders = (Kind -> [TyVarBndr Specificity]) -> Cxt -> [TyVarBndr Specificity]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Kind -> [TyVarBndr Specificity]
binderFromType Cxt
dtTypes
varNames :: [Name]
varNames = TyVarBndr Specificity -> Name
nameFromBinder (TyVarBndr Specificity -> Name)
-> [TyVarBndr Specificity] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr Specificity]
dtBinders
usedVars :: [Name]
usedVars = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
fieldVars) [Name]
varNames
tyI :: TypeQ
tyI = Kind -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> TypeQ) -> Kind -> TypeQ
forall a b. (a -> b) -> a -> b
$ (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Kind -> Kind -> Kind) -> Kind -> Kind -> Kind
forall a b c. (a -> b -> c) -> b -> a -> c
flip Kind -> Kind -> Kind
AppT) (Name -> Kind
ConT Name
datatype) (Cxt -> Cxt
forall a. [a] -> [a]
reverse Cxt
dtTypes)
pretties :: [TyVarBndr Specificity]
pretties = (Name -> Name) -> TyVarBndr Specificity -> TyVarBndr Specificity
mapTyVarBndr Name -> Name
pretty (TyVarBndr Specificity -> TyVarBndr Specificity)
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr Specificity]
dtBinders
mono :: Bool
mono = Bool
forcedMono Bool -> Bool -> Bool
|| Kind -> [TyVarBndr Specificity] -> Bool
isMonomorphic Kind
fieldtype [TyVarBndr Specificity]
dtBinders
if Bool
mono
then Typing -> Q Typing
forall (m :: * -> *) a. Monad m => a -> m a
return (Typing -> Q Typing) -> Typing -> Q Typing
forall a b. (a -> b) -> a -> b
$ Bool -> TypeQ -> TypeQ -> [TyVarBndr Specificity] -> Typing
Typing
Bool
mono
(Kind -> Kind
prettyType (Kind -> Kind) -> TypeQ -> TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ
tyI)
(Kind -> Kind
prettyType (Kind -> Kind) -> TypeQ -> TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ
tyO)
([TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. Eq a => [a] -> [a]
nub [TyVarBndr Specificity]
pretties)
else
do let names :: [String]
names = Char -> String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> String) -> String -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char
'a'..Char
'z']
used :: [String]
used = Name -> String
forall a. Show a => a -> String
show (Name -> String) -> (Name -> Name) -> Name -> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> Name
pretty (Name -> String) -> [Name] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
varNames
free :: [String]
free = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
used)) [String]
names
[(Name, Name)]
subs <- [(Name, String)]
-> ((Name, String) -> Q (Name, Name)) -> Q [(Name, Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Name] -> [String] -> [(Name, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
usedVars [String]
free) (\(Name
a, String
b) -> (,) Name
a (Name -> (Name, Name)) -> Q Name -> Q (Name, Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName String
b)
let rename :: Kind -> Kind
rename = (Name -> Name) -> Kind -> Kind
mapTypeVariables (\Name
a -> Name
a Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
`fromMaybe` Name -> [(Name, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
a [(Name, Name)]
subs)
Typing -> Q Typing
forall (m :: * -> *) a. Monad m => a -> m a
return (Typing -> Q Typing) -> Typing -> Q Typing
forall a b. (a -> b) -> a -> b
$ Bool -> TypeQ -> TypeQ -> [TyVarBndr Specificity] -> Typing
Typing
Bool
mono
(Kind -> Kind
prettyType (Kind -> Kind) -> TypeQ -> TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| $tyI -> $(rename <$> tyI) |])
(Kind -> Kind
prettyType (Kind -> Kind) -> TypeQ -> TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| $tyO -> $(rename <$> tyO) |])
([TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. Eq a => [a] -> [a]
nub ([TyVarBndr Specificity]
pretties [TyVarBndr Specificity]
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. [a] -> [a] -> [a]
++ (TyVarBndr Specificity -> TyVarBndr Specificity)
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> Name) -> TyVarBndr Specificity -> TyVarBndr Specificity
mapTyVarBndr Name -> Name
pretty)
#if MIN_VERSION_template_haskell(2,17,0)
(flip PlainTV SpecifiedSpec . snd <$> subs)))
#else
(Name -> TyVarBndr Specificity
PlainTV (Name -> TyVarBndr Specificity)
-> ((Name, Name) -> Name) -> (Name, Name) -> TyVarBndr Specificity
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Name, Name) -> Name
forall a b. (a, b) -> b
snd ((Name, Name) -> TyVarBndr Specificity)
-> [(Name, Name)] -> [TyVarBndr Specificity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Name)]
subs)))
#endif
isMonomorphic :: Type -> [TyVarBndr Specificity] -> Bool
isMonomorphic :: Kind -> [TyVarBndr Specificity] -> Bool
isMonomorphic Kind
field [TyVarBndr Specificity]
vars =
let fieldVars :: [Name]
fieldVars = Kind -> [Name]
typeVariables Kind
field
varNames :: [Name]
varNames = TyVarBndr Specificity -> Name
nameFromBinder (TyVarBndr Specificity -> Name)
-> [TyVarBndr Specificity] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr Specificity]
vars
usedVars :: [Name]
usedVars = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
fieldVars) [Name]
varNames
in [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
usedVars
typeVariables :: Type -> [Name]
typeVariables :: Kind -> [Name]
typeVariables = (TyVarBndr Specificity -> Name)
-> [TyVarBndr Specificity] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr Specificity -> Name
nameFromBinder ([TyVarBndr Specificity] -> [Name])
-> (Kind -> [TyVarBndr Specificity]) -> Kind -> [Name]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Kind -> [TyVarBndr Specificity]
binderFromType
typeFromBinder :: TyVarBndr a -> Type
#if MIN_VERSION_template_haskell(2,17,0)
typeFromBinder (PlainTV tv _) = VarT tv
#else
typeFromBinder :: TyVarBndr Specificity -> Kind
typeFromBinder (PlainTV Name
tv ) = Name -> Kind
VarT Name
tv
#endif
#if MIN_VERSION_template_haskell(2,17,0)
typeFromBinder (KindedTV tv _ StarT) = VarT tv
typeFromBinder (KindedTV tv _ kind) = SigT (VarT tv) kind
#elif MIN_VERSION_template_haskell(2,8,0)
typeFromBinder (KindedTV Name
tv Kind
StarT) = Name -> Kind
VarT Name
tv
typeFromBinder (KindedTV Name
tv Kind
kind) = Kind -> Kind -> Kind
SigT (Name -> Kind
VarT Name
tv) Kind
kind
#else
typeFromBinder (KindedTV tv StarK) = VarT tv
typeFromBinder (KindedTV tv kind) = SigT (VarT tv) kind
#endif
binderFromType :: Type -> [TyVarBndr Specificity]
binderFromType :: Kind -> [TyVarBndr Specificity]
binderFromType = Kind -> [TyVarBndr Specificity]
go
where
go :: Kind -> [TyVarBndr Specificity]
go Kind
ty =
case Kind
ty of
ForallT [TyVarBndr Specificity]
ts Cxt
_ Kind
_ -> [TyVarBndr Specificity]
ts
AppT Kind
a Kind
b -> Kind -> [TyVarBndr Specificity]
go Kind
a [TyVarBndr Specificity]
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. [a] -> [a] -> [a]
++ Kind -> [TyVarBndr Specificity]
go Kind
b
SigT Kind
t Kind
_ -> Kind -> [TyVarBndr Specificity]
go Kind
t
#if MIN_VERSION_template_haskell(2,17,0)
VarT n -> [PlainTV n SpecifiedSpec]
#else
VarT Name
n -> [Name -> TyVarBndr Specificity
PlainTV Name
n]
#endif
Kind
_ -> []
mapTypeVariables :: (Name -> Name) -> Type -> Type
mapTypeVariables :: (Name -> Name) -> Kind -> Kind
mapTypeVariables Name -> Name
f = Kind -> Kind
go
where
go :: Kind -> Kind
go Kind
ty =
case Kind
ty of
ForallT [TyVarBndr Specificity]
ts Cxt
a Kind
b -> [TyVarBndr Specificity] -> Cxt -> Kind -> Kind
ForallT ((Name -> Name) -> TyVarBndr Specificity -> TyVarBndr Specificity
mapTyVarBndr Name -> Name
f (TyVarBndr Specificity -> TyVarBndr Specificity)
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr Specificity]
ts)
((Name -> Name) -> Kind -> Kind
mapPred Name -> Name
f (Kind -> Kind) -> Cxt -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt
a) (Kind -> Kind
go Kind
b)
AppT Kind
a Kind
b -> Kind -> Kind -> Kind
AppT (Kind -> Kind
go Kind
a) (Kind -> Kind
go Kind
b)
SigT Kind
t Kind
a -> Kind -> Kind -> Kind
SigT (Kind -> Kind
go Kind
t) Kind
a
VarT Name
n -> Name -> Kind
VarT (Name -> Name
f Name
n)
Kind
t -> Kind
t
mapType :: (Type -> Type) -> Type -> Type
mapType :: (Kind -> Kind) -> Kind -> Kind
mapType Kind -> Kind
f = Kind -> Kind
go
where
go :: Kind -> Kind
go Kind
ty =
case Kind
ty of
ForallT [TyVarBndr Specificity]
v Cxt
c Kind
t -> Kind -> Kind
f ([TyVarBndr Specificity] -> Cxt -> Kind -> Kind
ForallT [TyVarBndr Specificity]
v Cxt
c (Kind -> Kind
go Kind
t))
AppT Kind
a Kind
b -> Kind -> Kind
f (Kind -> Kind -> Kind
AppT (Kind -> Kind
go Kind
a) (Kind -> Kind
go Kind
b))
SigT Kind
t Kind
k -> Kind -> Kind
f (Kind -> Kind -> Kind
SigT (Kind -> Kind
go Kind
t) Kind
k)
Kind
_ -> Kind -> Kind
f Kind
ty
substitute :: Subst -> Type -> Type
substitute :: Subst -> Kind -> Kind
substitute Subst
env = (Kind -> Kind) -> Kind -> Kind
mapType Kind -> Kind
sub
where sub :: Kind -> Kind
sub Kind
v = case Kind -> Subst -> Maybe Kind
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Kind
v Subst
env of
Maybe Kind
Nothing -> Kind
v
Just Kind
w -> Kind
w
nameFromBinder :: TyVarBndr Specificity -> Name
#if MIN_VERSION_template_haskell(2,17,0)
nameFromBinder (PlainTV n _) = n
nameFromBinder (KindedTV n _ _) = n
#else
nameFromBinder :: TyVarBndr Specificity -> Name
nameFromBinder (PlainTV Name
n ) = Name
n
nameFromBinder (KindedTV Name
n Kind
_) = Name
n
#endif
mapPred :: (Name -> Name) -> Pred -> Pred
#if MIN_VERSION_template_haskell(2,10,0)
mapPred :: (Name -> Name) -> Kind -> Kind
mapPred = (Name -> Name) -> Kind -> Kind
mapTypeVariables
#else
mapPred f (ClassP n ts) = ClassP (f n) (mapTypeVariables f <$> ts)
mapPred f (EqualP t x ) = EqualP (mapTypeVariables f t) (mapTypeVariables f x)
#endif
mapTyVarBndr :: (Name -> Name) -> TyVarBndr Specificity
-> TyVarBndr Specificity
#if MIN_VERSION_template_haskell(2,17,0)
mapTyVarBndr f (PlainTV n flag) = PlainTV (f n) flag
mapTyVarBndr f (KindedTV n a flag) = KindedTV (f n) a flag
#else
mapTyVarBndr :: (Name -> Name) -> TyVarBndr Specificity -> TyVarBndr Specificity
mapTyVarBndr Name -> Name
f (PlainTV Name
n) = Name -> TyVarBndr Specificity
PlainTV (Name -> Name
f Name
n)
mapTyVarBndr Name -> Name
f (KindedTV Name
n Kind
a) = Name -> Kind -> TyVarBndr Specificity
KindedTV (Name -> Name
f Name
n) Kind
a
#endif
pretty :: Name -> Name
pretty :: Name -> Name
pretty Name
tv = String -> Name
mkName ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_') (Name -> String
forall a. Show a => a -> String
show Name
tv))
prettyType :: Type -> Type
prettyType :: Kind -> Kind
prettyType = (Name -> Name) -> Kind -> Kind
mapTypeVariables Name -> Name
pretty
reifyDec :: Name -> Q Dec
reifyDec :: Name -> Q Dec
reifyDec Name
name =
do Info
info <- Name -> Q Info
reify Name
name
case Info
info of
TyConI Dec
dec -> Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
dec
Info
_ -> String -> Q Dec
forall a. String -> a
fclError String
"Info must be type declaration type."
fclError :: String -> a
fclError :: String -> a
fclError String
err = String -> a
forall a. HasCallStack => String -> a
error (String
"Data.Label.Derive: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
#if MIN_VERSION_template_haskell(2,10,0)
classP :: Name -> [Q Type] -> Q Pred
classP :: Name -> [TypeQ] -> TypeQ
classP Name
cla [TypeQ]
tys
= do Cxt
tysl <- [TypeQ] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [TypeQ]
tys
Kind -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return ((Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
cla) Cxt
tysl)
#endif
trd :: (a, b, c) -> c
trd :: (a, b, c) -> c
trd (a
_, b
_, c
x) = c
x