{- |
Template Haskell functions for automatically generating labels for algebraic
datatypes, newtypes and GADTs. There are two basic modes of label generation,
the `mkLabels` family of functions create labels (and optionally type
signatures) in scope as top level funtions, the `getLabel` family of funtions
create labels as expressions that can be named and typed manually.

In the case of multi-constructor datatypes some fields might not always be
available and the derived labels will be partial. Partial labels are provided
with an additional type context that forces them to be only usable in the
`Partial' or `Failing` context.
-}

{-# LANGUAGE
    DeriveFunctor
  , DeriveFoldable
  , TemplateHaskell
  , TypeOperators
  , CPP #-}

module Data.Label.Derive
(

-- * Generate labels in scope.
  mkLabel
, mkLabels
, mkLabelsNamed

-- * Produce labels as expressions.
, getLabel

-- * First class record labels.
, fclabels

-- * Low level derivation functions.
, 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 -- old versions don't have this
type TyVarBndr a = TH.TyVarBndr
#endif

-------------------------------------------------------------------------------
-- Publicly exposed functions.

-- | Derive labels including type signatures for all the record selectors for a
-- collection of datatypes. The types will be polymorphic and can be used in an
-- arbitrary context.

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)

-- | Derive labels including type signatures for all the record selectors in a
-- single datatype. The types will be polymorphic and can be used in an
-- arbitrary context.

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

-- | Like `mkLabels`, but uses the specified function to produce custom names
-- for the labels.
--
-- For instance, @(drop 1 . dropWhile (/='_'))@ creates a label
-- @val@ from a record @Rec { rec_val :: X }@.

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)

-- | Derive unnamed labels as n-tuples that can be named manually. The types
-- will be polymorphic and can be used in an arbitrary context.
--
-- Example:
--
-- > (left, right) = $(getLabel ''Either)
--
-- The lenses can now also be typed manually:
--
-- > left  :: (Either a b -> Either c b) :~> (a -> c)
-- > right :: (Either a b -> Either a c) :~> (b -> c)
--
-- Note: Because of the abstract nature of the generated lenses and the top
-- level pattern match, it might be required to use 'NoMonomorphismRestriction'
-- in some cases.

getLabel :: Name -> Q Exp
getLabel :: Name -> Q Exp
getLabel = Bool -> Bool -> Bool -> Name -> Q Exp
getLabelWith Bool
True Bool
False Bool
False

-- | Low level label as expression derivation function.

getLabelWith
  :: Bool  -- ^ Generate type signatures or not.
  -> Bool  -- ^ Generate concrete type or abstract type. When true the
           --   signatures will be concrete and can only be used in the
           --   appropriate context. Total labels will use (`:->`) and partial
           --   labels will use either `Lens Partial` or `Lens Failing`
           --   dependent on the following flag:
  -> Bool  -- ^ Use `ArrowFail` for failure instead of `ArrowZero`.
  -> Name  -- ^ The type to derive labels for.
  -> 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

-- | Low level standalone label derivation function.

mkLabelsWith
  :: (String -> String) -- ^ Supply a function to perform custom label naming.
  -> Bool               -- ^ Generate type signatures or not.
  -> Bool               -- ^ Generate concrete type or abstract type. When
                        --   true the signatures will be concrete and can only
                        --   be used in the appropriate context. Total labels
                        --   will use (`:->`) and partial labels will use
                        --   either `Lens Partial` or `Lens Failing` dependent
                        --   on the following flag:
  -> Bool               -- ^ Use `ArrowFail` for failure instead of `ArrowZero`.
  -> Bool               -- ^ Generate inline pragma or not.
  -> Name               -- ^ The type to derive labels for.
  -> 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

-- | Default way of generating a label name from the Haskell record selector
-- name. If the original selector starts with an underscore, remove it and make
-- the next character lowercase. Otherwise, add 'l', and make the next
-- character uppercase.

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)

-- | Derive labels for all the record types in the supplied declaration. The
-- record fields don't need an underscore prefix. Multiple data types /
-- newtypes are allowed at once.
--
-- The advantage of this approach is that you don't need to explicitly hide the
-- original record accessors from being exported and they won't show up in the
-- derived `Show` instance.
--
-- Example:
--
-- > fclabels [d|
-- >   data Record = Record
-- >     { int  :: Int
-- >     , bool :: Bool
-- >     } deriving Show
-- >   |]
--
-- > ghci> modify int (+2) (Record 1 False)
-- > Record 3 False

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

-------------------------------------------------------------------------------
-- Intermediate data types.

data Label
 = LabelDecl
     Name              -- The label name.
     DecQ              -- An INLINE pragma for the label.
     [TyVarBndr Specificity] -- The type variables requiring forall.
     CxtQ              -- The context.
     TypeQ             -- The type.
     ExpQ              -- The label body.
 | LabelExpr
     [TyVarBndr Specificity] -- The type variables requiring forall.
     CxtQ              -- The context.
     TypeQ             -- The type.
     ExpQ              -- The label body.

data Field c = Field
  (Maybe Name)         -- Name of the field, when there is one.
  Bool                 -- Forced to be mono because of type shared with other fields.
  Type                 -- Type of the field.
  c                    -- Occurs in this/these constructors.
  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                  -- Field index.
  Name                 -- Constructor name.
  Con                  -- Constructor.
  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                 -- Monomorphic type or polymorphic.
  TypeQ                -- The lens input type.
  TypeQ                -- The lens output type.
  [TyVarBndr Specificity] -- All used type variables.

-------------------------------------------------------------------------------

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)

-- Generate the labels for all the record fields in the data type.

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 -- Only process data and newtype declarations, filter out all
    -- constructors and the type variables.
    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."

        -- We are only interested in lenses of record constructors.
        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)
           -- Generate an inline declaration for the label.
           -- Type of InlineSpec removed in TH-2.8.0 (GHC 7.6)
           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

-- Build a total polymorphic modification function from a getter and setter.

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

-------------------------------------------------------------------------------
-- Generic helper functions dealing with Template Haskell

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

-- Prettify a TH name.

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))

-- Prettify a type.

prettyType :: Type -> Type
prettyType :: Kind -> Kind
prettyType = (Name -> Name) -> Kind -> Kind
mapTypeVariables Name -> Name
pretty

-- Reify a name into a declaration.

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."

-- Throw a fclabels specific error.

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