{-# 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 = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id Bool
concrete Bool
failing Dec
dec
let bodies :: [Q Exp]
bodies = forall a b. (a -> b) -> [a] -> [b]
map (\(LabelExpr [TyVarBndr Specificity]
_ CxtQ
_ TypeQ
_ Q Exp
b) -> Q Exp
b) [Label]
labels
types :: [TypeQ]
types = forall a b. (a -> b) -> [a] -> [b]
map (\(LabelExpr [TyVarBndr Specificity]
_ CxtQ
_ TypeQ
t Q Exp
_) -> TypeQ
t) [Label]
labels
context :: CxtQ
context = forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(LabelExpr [TyVarBndr Specificity]
_ CxtQ
c TypeQ
_ Q Exp
_) -> CxtQ
c) [Label]
labels
vars :: [TyVarBndr Specificity]
vars = forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ 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 forall (m :: * -> *). Quote m => m Exp -> m Kind -> m Exp
`sigE` forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Kind -> m Kind
forallT [TyVarBndr Specificity]
vars CxtQ
context (forall a. [a] -> a
head [TypeQ]
types) else Q Exp
b
[Q Exp]
_ -> if Bool
sigs
then forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [Q Exp]
bodies forall (m :: * -> *). Quote m => m Exp -> m Kind -> m Exp
`sigE`
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Kind -> m Kind
forallT [TyVarBndr Specificity]
vars CxtQ
context (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
appT (forall (m :: * -> *). Quote m => Int -> m Kind
tupleT (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Exp]
bodies)) [TypeQ]
types)
else forall (m :: * -> *). Quote m => [m Exp] -> m 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 forall a. a -> [a] -> [a]
: String
rest
Char
f : String
rest -> Char
'l' forall a. a -> [a] -> [a]
: Char -> Char
toUpper Char
f forall a. a -> [a] -> [a]
: String
rest
String
n -> forall a. String -> a
fclError (String
"Cannot derive label for record selector with name: " 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Dec]
ds 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 forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id Bool
True Bool
False Bool
False Bool
False)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Dec -> Dec
delabelize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Dec]
ds) 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 ()]
vars Maybe Kind
mk [Con]
cs [DerivClause]
ns -> Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD Cxt
ctx Name
nm [TyVarBndr ()]
vars Maybe Kind
mk (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 ()]
vars Maybe Kind
mk Con
c [DerivClause]
ns -> Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> Con
-> [DerivClause]
-> Dec
NewtypeD Cxt
ctx Name
nm [TyVarBndr ()]
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 (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 (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
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, 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
<$ :: forall a b. a -> Field b -> Field a
$c<$ :: forall a b. a -> Field b -> Field a
fmap :: forall a b. (a -> b) -> Field a -> Field b
$cfmap :: forall a b. (a -> b) -> Field a -> Field b
Functor, 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 :: forall a. Num a => Field a -> a
$cproduct :: forall a. Num a => Field a -> a
sum :: forall a. Num a => Field a -> a
$csum :: forall a. Num a => Field a -> a
minimum :: forall a. Ord a => Field a -> a
$cminimum :: forall a. Ord a => Field a -> a
maximum :: forall a. Ord a => Field a -> a
$cmaximum :: forall a. Ord a => Field a -> a
elem :: forall a. Eq a => a -> Field a -> Bool
$celem :: forall a. Eq a => a -> Field a -> Bool
length :: forall a. Field a -> Int
$clength :: forall a. Field a -> Int
null :: forall a. Field a -> Bool
$cnull :: forall a. Field a -> Bool
toList :: forall a. Field a -> [a]
$ctoList :: forall a. Field a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Field a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Field a -> a
foldr1 :: forall a. (a -> a -> a) -> Field a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Field a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Field a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Field a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Field a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Field a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Field a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Field a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Field a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Field a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Field a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Field a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Field a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Field a -> m
fold :: forall m. Monoid m => 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
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
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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Label]
labels forall a b. (a -> b) -> a -> b
$ \Label
l ->
case Label
l of
LabelExpr {} -> 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 <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
n [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
b) []]
[Dec]
prg <- if Bool
inl then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
i else forall (m :: * -> *) a. Monad m => a -> m a
return []
[Dec]
typ <- if Bool
sigs
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
sigD Name
n (forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Kind -> m Kind
forallT [TyVarBndr Specificity]
v CxtQ
c TypeQ
t)
else forall (m :: * -> *) a. Monad m => a -> m a
return []
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]
prg, [Dec]
typ, [Dec]
bdy])
forall (m :: * -> *) a. Monad m => a -> m a
return (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 ()]
vars) =
case Dec
dec of
#if MIN_VERSION_template_haskell(2,11,0)
DataD Cxt
_ Name
n [TyVarBndr ()]
vs Maybe Kind
_ [Con]
cs [DerivClause]
_ -> (Name
n, [Con]
cs, [TyVarBndr ()]
vs)
NewtypeD Cxt
_ Name
n [TyVarBndr ()]
vs Maybe Kind
_ Con
c [DerivClause]
_ -> (Name
n, [Con
c], [TyVarBndr ()]
vs)
#else
DataD _ n vs cs _ -> (n, cs, vs)
NewtypeD _ n vs c _ -> (n, [c], vs)
#endif
Dec
_ -> forall a. String -> a
fclError String
"Can only derive labels for datatypes and newtypes."
fields :: [Field ([Context], Subst)]
fields = forall a.
(String -> String)
-> [TyVarBndr a] -> [Con] -> [Field ([Context], Subst)]
groupFields String -> String
mk [TyVarBndr ()]
vars [Con]
cons
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Field ([Context], Subst)]
fields forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Name
-> [TyVarBndr ()]
-> [Con]
-> Field ([Context], Subst)
-> Q Label
generateLabel Bool
failing Bool
concrete Name
name [TyVarBndr ()]
vars [Con]
cons
groupFields :: (String -> String) -> [TyVarBndr a] -> [Con]
-> [Field ([Context], Subst)]
groupFields :: forall a.
(String -> String)
-> [TyVarBndr a] -> [Con] -> [Field ([Context], Subst)]
groupFields String -> String
mk [TyVarBndr a]
vs
= forall a b. (a -> b) -> [a] -> [b]
map (forall {c}. (String -> String) -> Field c -> Field c
rename String -> String
mk)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\[Field (Context, Subst)]
fs -> let vals :: [(Context, Subst)]
vals = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field (Context, Subst)]
fs)
cons :: [Context]
cons = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Context, Subst)]
vals
subst :: Subst
subst = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Context, Subst)]
vals)
in forall a. Eq a => [a] -> [a]
nub (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const ([Context]
cons, Subst
subst)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field (Context, Subst)]
fs)
)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy forall {c} {c}. Field c -> Field c -> Bool
eq
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall {c}. Field c -> Maybe Name
name)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. [TyVarBndr a] -> Con -> [Field (Context, Subst)]
constructorFields [TyVarBndr a]
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 forall a. a -> Maybe a -> a
`fromMaybe` (forall a. Eq a => a -> a -> Bool
(==) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {c}. Field c -> Maybe Name
name Field c
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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) =
forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field (String -> Name
mkName 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 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 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 :: forall a. [TyVarBndr a] -> Con -> [Field (Context, Subst)]
constructorFields [TyVarBndr a]
vs Con
con =
case Con
con of
NormalC Name
c [BangType]
fs -> forall {a}. (Int, BangType) -> Field (Context, [a])
one forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)) = forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field forall a. Maybe a
Nothing Bool
mono Kind
ty (Int -> Name -> Con -> Context
Context Int
i Name
c Con
con, [])
where fsTys :: [[Name]]
fsTys = forall a b. (a -> b) -> [a] -> [b]
map (Kind -> [Name]
typeVariables forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (a, b) -> b
snd) (forall a. Eq a => a -> [a] -> [a]
delete BangType
f [BangType]
fs)
mono :: Bool
mono = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
x -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (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 -> forall {a}. (Int, VarBangType) -> Field (Context, [a])
one forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)) = forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field (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 = forall a b. (a -> b) -> [a] -> [b]
map (Kind -> [Name]
typeVariables forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b c. (a, b, c) -> c
trd) (forall a. Eq a => a -> [a] -> [a]
delete VarBangType
f [VarBangType]
fs)
mono :: Bool
mono = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
x -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (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 -> forall {a} {a}. (Int, (a, Kind)) -> Field (Context, [a])
one 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)) = forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field forall a. Maybe a
Nothing Bool
mono Kind
ty (Int -> Name -> Con -> Context
Context Int
i Name
c Con
con, [])
where fsTys :: [[Name]]
fsTys = forall a b. (a -> b) -> [a] -> [b]
map (Kind -> [Name]
typeVariables forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (a, b) -> b
snd) [BangType
a, BangType
b]
mono :: Bool
mono = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
x -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [TyVarBndr a] -> Con -> [Field (Context, Subst)]
constructorFields [TyVarBndr a]
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) = forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field Maybe Name
a Bool
b Kind
c (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Context -> Context
upd forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Subst
eqs forall a. [a] -> [a] -> [a]
++) 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 -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Name
c -> Name -> (Int, BangType) -> Field (Context, Subst)
one Name
c forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)) = forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field forall a. Maybe a
Nothing Bool
mono Kind
ty (Int -> Name -> Con -> Context
Context Int
i Name
c Con
con, forall a. [TyVarBndr a] -> Kind -> Subst
mkSubst [TyVarBndr a]
vs Kind
resTy)
where fsTys :: [[Name]]
fsTys = forall a b. (a -> b) -> [a] -> [b]
map (Kind -> [Name]
typeVariables forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (a, b) -> b
snd) (forall a. Eq a => a -> [a] -> [a]
delete BangType
f [BangType]
fs)
mono :: Bool
mono = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
x -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (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 -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Name
c -> Name -> (Int, VarBangType) -> Field (Context, Subst)
one Name
c forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)) = forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field (forall a. a -> Maybe a
Just Name
n) Bool
mono Kind
ty (Int -> Name -> Con -> Context
Context Int
i Name
c Con
con, forall a. [TyVarBndr a] -> Kind -> Subst
mkSubst [TyVarBndr a]
vs Kind
resTy)
where fsTys :: [[Name]]
fsTys = forall a b. (a -> b) -> [a] -> [b]
map (Kind -> [Name]
typeVariables forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b c. (a, b, c) -> c
trd) (forall a. Eq a => a -> [a] -> [a]
delete VarBangType
f [VarBangType]
fs)
mono :: Bool
mono = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
x -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (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 :: forall a. [TyVarBndr a] -> Kind -> Subst
mkSubst [TyVarBndr a]
vars Kind
t = forall a. [TyVarBndr a] -> Kind -> Subst
go (forall a. [a] -> [a]
reverse [TyVarBndr a]
vars) Kind
t
where
go :: [TyVarBndr a] -> Kind -> Subst
go [] Kind
_ = []
go (TyVarBndr a
v:[TyVarBndr a]
vs) (AppT Kind
t1 Kind
t2) = (forall a. TyVarBndr a -> Kind
typeFromBinder TyVarBndr a
v, Kind
t2) forall a. a -> [a] -> [a]
: [TyVarBndr a] -> Kind -> Subst
go [TyVarBndr a]
vs Kind
t1
go [TyVarBndr a]
_ Kind
_ = 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]
_
-> 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 = forall (t :: * -> *). Foldable t => t Bool -> Bool
and (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 forall a. [a] -> [a] -> [a]
++ [Kind
ty]
conIndices Kind
_ = 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 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 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 ()]
-> [Con]
-> Field ([Context], Subst)
-> Q Label
generateLabel Bool
failing Bool
concrete Name
datatype [TyVarBndr ()]
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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Context]
contexts forall a. Eq a => a -> a -> Bool
== 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 ()] -> Subst -> Q Typing
computeTypes Bool
forcedMono Kind
fieldtype Name
datatype [TyVarBndr ()]
dtVars Subst
subst
let cat :: TypeQ
cat = forall (m :: * -> *). Quote m => Name -> m Kind
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 forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt [ Name -> [TypeQ] -> TypeQ
classP ''ArrowApply [TypeQ
cat] ]
else forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
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 forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
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 <- forall a. Eq a => [a] -> [a]
nub 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ
ty
forall (m :: * -> *) a. Monad m => a -> m a
return 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 (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 :: forall (cat :: * -> * -> *) f o i g.
ArrowApply cat =>
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 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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)) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE []) (forall (m :: * -> *). Quote m => Lit -> m Exp
litE 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 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) (forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
failing forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Name
mn)
wild :: [Q Match]
wild = if Bool
total then [] else [forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| Left $(nm) |]) []]
rght :: Q Exp -> Q Exp
rght = if Bool
total then forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id else forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| Right |]
mkCase :: Context -> [Q Match]
mkCase (Context Int
i Name
_ Con
c) = forall a b. (a -> b) -> [a] -> [b]
map (\(Q Pat
pat, Q Exp
var) -> forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match Q Pat
pat (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Exp
rght Q Exp
var)) []) (Int -> Con -> [(Q Pat, Q Exp)]
case1 Int
i Con
c)
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
pt]
(forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pt) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Context -> [Q Match]
mkCase [Context]
cons forall a. [a] -> [a] -> [a]
++ [Q Match]
wild))
where
case1 :: Int -> Con -> [(Q Pat, Q Exp)]
case1 :: Int -> Con -> [(Q Pat, Q Exp)]
case1 Int
i Con
con =
case Con
con of
NormalC Name
c [BangType]
fs -> [forall {t :: * -> *} {a}.
Foldable t =>
t a -> Name -> (Q Pat, Q Exp)
one [BangType]
fs Name
c]
RecC Name
c [VarBangType]
fs -> [forall {t :: * -> *} {a}.
Foldable t =>
t a -> Name -> (Q Pat, Q Exp)
one [VarBangType]
fs Name
c]
InfixC BangType
_ Name
c BangType
_ -> [(forall (m :: * -> *). Quote m => m Pat -> Name -> m Pat -> m Pat
infixP ([Q Pat]
pats forall a. [a] -> Int -> a
!! Int
0) Name
c ([Q Pat]
pats forall a. [a] -> Int -> a
!! Int
1), Q Exp
var)]
ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
c -> Int -> Con -> [(Q Pat, Q Exp)]
case1 Int
i Con
c
#if MIN_VERSION_template_haskell(2,11,0)
GadtC [Name]
cs [BangType]
fs Kind
_ -> forall a b. (a -> b) -> [a] -> [b]
map (forall {t :: * -> *} {a}.
Foldable t =>
t a -> Name -> (Q Pat, Q Exp)
one [BangType]
fs) [Name]
cs
RecGadtC [Name]
cs [VarBangType]
fs Kind
_ -> forall a b. (a -> b) -> [a] -> [b]
map (forall {t :: * -> *} {a}.
Foldable t =>
t a -> Name -> (Q Pat, Q Exp)
one [VarBangType]
fs) [Name]
cs
#endif
where fresh :: [Name]
fresh = String -> Name
mkName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Eq a => a -> [a] -> [a]
delete String
"f" [String]
freshNames
pats1 :: [Q Pat]
pats1 = forall (m :: * -> *). Quote m => Name -> m Pat
varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fresh
pats :: [Q Pat]
pats = forall a. Int -> a -> [a]
replicate Int
i forall (m :: * -> *). Quote m => m Pat
wildP forall a. [a] -> [a] -> [a]
++ [[Q Pat]
pats1 forall a. [a] -> Int -> a
!! Int
i] forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat forall (m :: * -> *). Quote m => m Pat
wildP
var :: Q Exp
var = forall (m :: * -> *). Quote m => Name -> m Exp
varE ([Name]
fresh forall a. [a] -> Int -> a
!! Int
i)
one :: t a -> Name -> (Q Pat, Q Exp)
one t a
fs Name
c = let s :: [a] -> [a]
s = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
fs) in (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
c (forall a. [a] -> [a]
s [Q Pat]
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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE []) (forall (m :: * -> *). Quote m => Lit -> m Exp
litE 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 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) (forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
failing forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Name
mn)
wild :: [Q Match]
wild = if Bool
total then [] else [forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| Left $(nm) |]) []]
rght :: Q Exp -> Q Exp
rght = if Bool
total then forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id else forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| Right |]
mkCase :: Context -> [Q Match]
mkCase (Context Int
i Name
_ Con
c) = forall a b. (a -> b) -> [a] -> [b]
map (\(Q Pat
pat, Q Exp
var) -> forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match Q Pat
pat (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Exp
rght Q Exp
var)) []) (forall {m :: * -> *} {m :: * -> *}.
(Quote m, Quote m) =>
Int -> Con -> [(m Pat, m Exp)]
case1 Int
i Con
c)
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
md, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
pt]]
(forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pt) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Context -> [Q Match]
mkCase [Context]
cons forall a. [a] -> [a] -> [a]
++ [Q Match]
wild))
where
case1 :: Int -> Con -> [(m Pat, m Exp)]
case1 Int
i Con
con =
case Con
con of
NormalC Name
c [BangType]
fs -> [forall {t :: * -> *} {a}.
Foldable t =>
t a -> Name -> (m Pat, m Exp)
one [BangType]
fs Name
c]
RecC Name
c [VarBangType]
fs -> [forall {t :: * -> *} {a}.
Foldable t =>
t a -> Name -> (m Pat, m Exp)
one [VarBangType]
fs Name
c]
InfixC BangType
_ Name
c BangType
_ -> [( forall (m :: * -> *). Quote m => m Pat -> Name -> m Pat -> m Pat
infixP ([m Pat]
pats forall a. [a] -> Int -> a
!! Int
0) Name
c ([m Pat]
pats forall a. [a] -> Int -> a
!! Int
1)
, forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (forall a. a -> Maybe a
Just ([m Exp]
vars forall a. [a] -> Int -> a
!! Int
0)) (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
c) (forall a. a -> Maybe a
Just ([m Exp]
vars forall a. [a] -> Int -> a
!! Int
1))
)
]
ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
c -> Int -> Con -> [(m Pat, m Exp)]
case1 Int
i Con
c
#if MIN_VERSION_template_haskell(2,11,0)
GadtC [Name]
cs [BangType]
fs Kind
_ -> forall a b. (a -> b) -> [a] -> [b]
map (forall {t :: * -> *} {a}.
Foldable t =>
t a -> Name -> (m Pat, m Exp)
one [BangType]
fs) [Name]
cs
RecGadtC [Name]
cs [VarBangType]
fs Kind
_ -> forall a b. (a -> b) -> [a] -> [b]
map (forall {t :: * -> *} {a}.
Foldable t =>
t a -> Name -> (m Pat, m Exp)
one [VarBangType]
fs) [Name]
cs
#endif
where fresh :: [Name]
fresh = String -> Name
mkName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Eq a => a -> [a] -> [a]
delete String
"f" (forall a. Eq a => a -> [a] -> [a]
delete String
"v" [String]
freshNames)
pats1 :: [m Pat]
pats1 = forall (m :: * -> *). Quote m => Name -> m Pat
varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fresh
pats :: [m Pat]
pats = forall a. Int -> [a] -> [a]
take Int
i [m Pat]
pats1 forall a. [a] -> [a] -> [a]
++ [forall (m :: * -> *). Quote m => m Pat
wildP] forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
drop (Int
i forall a. Num a => a -> a -> a
+ Int
1) [m Pat]
pats1
vars1 :: [m Exp]
vars1 = forall (m :: * -> *). Quote m => Name -> m Exp
varE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fresh
v :: m Exp
v = forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"v")
vars :: [m Exp]
vars = forall a. Int -> [a] -> [a]
take Int
i [m Exp]
vars1 forall a. [a] -> [a] -> [a]
++ [m Exp
v] forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
drop (Int
i forall a. Num a => a -> a -> a
+ Int
1) [m Exp]
vars1
apps :: m Exp -> t (m Exp) -> m Exp
apps m Exp
f t (m Exp)
as = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE m Exp
f t (m Exp)
as
one :: t a -> Name -> (m Pat, m Exp)
one t a
fs Name
c = let s :: [a] -> [a]
s = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
fs) in (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
c (forall a. [a] -> [a]
s [m Pat]
pats), forall {t :: * -> *} {m :: * -> *}.
(Foldable t, Quote m) =>
m Exp -> t (m Exp) -> m Exp
apps (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
c) (forall a. [a] -> [a]
s [m Exp]
vars))
freshNames :: [String]
freshNames :: [String]
freshNames = forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char
'a'..Char
'z'] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map ((Char
'a'forall a. a -> [a] -> [a]
:) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Show a => a -> String
show) [Integer
0 :: Integer ..]
computeTypes :: Bool -> Type -> Name -> [TyVarBndr ()] -> Subst -> Q Typing
computeTypes :: Bool -> Kind -> Name -> [TyVarBndr ()] -> Subst -> Q Typing
computeTypes Bool
forcedMono Kind
fieldtype Name
datatype [TyVarBndr ()]
dtVars_ Subst
subst =
do let fieldVars :: [Name]
fieldVars = Kind -> [Name]
typeVariables Kind
fieldtype
tyO :: TypeQ
tyO = forall (m :: * -> *) a. Monad m => a -> m a
return Kind
fieldtype
dtTypes :: Cxt
dtTypes = Subst -> Kind -> Kind
substitute Subst
subst forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. TyVarBndr a -> Kind
typeFromBinder forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr ()]
dtVars_
dtBinders :: [TyVarBndr Specificity]
dtBinders = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr Specificity]
dtBinders
usedVars :: [Name]
usedVars = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
fieldVars) [Name]
varNames
tyI :: TypeQ
tyI = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> b -> a -> c
flip Kind -> Kind -> Kind
AppT) (Name -> Kind
ConT Name
datatype) (forall a. [a] -> [a]
reverse Cxt
dtTypes)
pretties :: [TyVarBndr Specificity]
pretties = (Name -> Name) -> TyVarBndr Specificity -> TyVarBndr Specificity
mapTyVarBndr Name -> Name
pretty 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 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> TypeQ -> TypeQ -> [TyVarBndr Specificity] -> Typing
Typing
Bool
mono
(Kind -> Kind
prettyType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ
tyI)
(Kind -> Kind
prettyType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ
tyO)
(forall a. Eq a => [a] -> [a]
nub [TyVarBndr Specificity]
pretties)
else
do let names :: [String]
names = forall (m :: * -> *) a. Monad m => a -> m a
return forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char
'a'..Char
'z']
used :: [String]
used = forall a. Show a => a -> String
show 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
varNames
free :: [String]
free = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
used)) [String]
names
[(Name, Name)]
subs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
usedVars [String]
free) (\(Name
a, String
b) -> (,) Name
a forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => String -> m Name
newName String
b)
let rename :: Kind -> Kind
rename = (Name -> Name) -> Kind -> Kind
mapTypeVariables (\Name
a -> Name
a forall a. a -> Maybe a -> a
`fromMaybe` forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
a [(Name, Name)]
subs)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> TypeQ -> TypeQ -> [TyVarBndr Specificity] -> Typing
Typing
Bool
mono
(Kind -> Kind
prettyType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| $tyI -> $(rename <$> tyI) |])
(Kind -> Kind
prettyType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| $tyO -> $(rename <$> tyO) |])
(forall a. Eq a => [a] -> [a]
nub ([TyVarBndr Specificity]
pretties forall a. [a] -> [a] -> [a]
++ 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)
(forall a b c. (a -> b -> c) -> b -> a -> c
flip forall flag. Name -> flag -> TyVarBndr flag
PlainTV Specificity
SpecifiedSpec forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Name)]
subs)))
#else
(PlainTV . snd <$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr Specificity]
vars
usedVars :: [Name]
usedVars = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
fieldVars) [Name]
varNames
in forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
usedVars
typeVariables :: Type -> [Name]
typeVariables :: Kind -> [Name]
typeVariables = forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr Specificity -> Name
nameFromBinder 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 :: forall a. TyVarBndr a -> Kind
typeFromBinder (PlainTV Name
tv a
_) = Name -> Kind
VarT Name
tv
#else
typeFromBinder (PlainTV tv ) = VarT tv
#endif
#if MIN_VERSION_template_haskell(2,17,0)
typeFromBinder (KindedTV Name
tv a
_ Kind
StarT) = Name -> Kind
VarT Name
tv
typeFromBinder (KindedTV Name
tv a
_ Kind
kind) = Kind -> Kind -> Kind
SigT (Name -> Kind
VarT Name
tv) Kind
kind
#elif MIN_VERSION_template_haskell(2,8,0)
typeFromBinder (KindedTV tv StarT) = VarT tv
typeFromBinder (KindedTV tv kind) = SigT (VarT tv) 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 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 Name
n -> [forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n Specificity
SpecifiedSpec]
#else
VarT n -> [PlainTV 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr Specificity]
ts)
((Name -> Name) -> Kind -> Kind
mapPred Name -> Name
f 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 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 :: TyVarBndr Specificity -> Name
nameFromBinder (PlainTV Name
n Specificity
_) = Name
n
nameFromBinder (KindedTV Name
n Specificity
_ Kind
_) = Name
n
#else
nameFromBinder (PlainTV n ) = n
nameFromBinder (KindedTV n _) = 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 :: (Name -> Name) -> TyVarBndr Specificity -> TyVarBndr Specificity
mapTyVarBndr Name -> Name
f (PlainTV Name
n Specificity
flag) = forall flag. Name -> flag -> TyVarBndr flag
PlainTV (Name -> Name
f Name
n) Specificity
flag
mapTyVarBndr Name -> Name
f (KindedTV Name
n Specificity
a Kind
flag) = forall flag. Name -> flag -> Kind -> TyVarBndr flag
KindedTV (Name -> Name
f Name
n) Specificity
a Kind
flag
#else
mapTyVarBndr f (PlainTV n) = PlainTV (f n)
mapTyVarBndr f (KindedTV n a) = KindedTV (f n) a
#endif
pretty :: Name -> Name
pretty :: Name -> Name
pretty Name
tv = String -> Name
mkName (forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'_') (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Dec
dec
Info
_ -> forall a. String -> a
fclError String
"Info must be type declaration type."
fclError :: String -> a
fclError :: forall a. String -> a
fclError String
err = forall a. HasCallStack => String -> a
error (String
"Data.Label.Derive: " 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 <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [TypeQ]
tys
forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: forall a b c. (a, b, c) -> c
trd (a
_, b
_, c
x) = c
x