{- |
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 = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec])
-> ([Name] -> Q [[Dec]]) -> [Name] -> Q [Dec]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((String -> String)
-> Bool -> Bool -> Bool -> Bool -> Name -> Q [Dec]
mkLabelsWith String -> String
defaultNaming Bool
True Bool
False Bool
False Bool
True)

-- | 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 ([Name] -> Q [Dec]) -> (Name -> [Name]) -> Name -> Q [Dec]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | 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 = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec])
-> ([Name] -> Q [[Dec]]) -> [Name] -> Q [Dec]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((String -> String)
-> Bool -> Bool -> Bool -> Bool -> Name -> Q [Dec]
mkLabelsWith String -> String
mk Bool
True Bool
False Bool
False Bool
True)

-- | 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 String -> String
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id Bool
concrete Bool
failing Dec
dec
     let bodies :: [Q Exp]
bodies  =        (Label -> Q Exp) -> [Label] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\(LabelExpr [TyVarBndr Specificity]
_ CxtQ
_ TypeQ
_ Q Exp
b) -> Q Exp
b) [Label]
labels
         types :: [TypeQ]
types   =        (Label -> TypeQ) -> [Label] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(LabelExpr [TyVarBndr Specificity]
_ CxtQ
_ TypeQ
t Q Exp
_) -> TypeQ
t) [Label]
labels
         context :: CxtQ
context = [CxtQ] -> CxtQ
forall a. [a] -> a
head ([CxtQ] -> CxtQ) -> [CxtQ] -> CxtQ
forall a b. (a -> b) -> a -> b
$ (Label -> CxtQ) -> [Label] -> [CxtQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(LabelExpr [TyVarBndr Specificity]
_ CxtQ
c TypeQ
_ Q Exp
_) -> CxtQ
c) [Label]
labels
         vars :: [TyVarBndr Specificity]
vars    = [[TyVarBndr Specificity]] -> [TyVarBndr Specificity]
forall a. [a] -> a
head ([[TyVarBndr Specificity]] -> [TyVarBndr Specificity])
-> [[TyVarBndr Specificity]] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> a -> b
$ (Label -> [TyVarBndr Specificity])
-> [Label] -> [[TyVarBndr Specificity]]
forall a b. (a -> b) -> [a] -> [b]
map (\(LabelExpr [TyVarBndr Specificity]
v CxtQ
_ TypeQ
_ Q Exp
_) -> [TyVarBndr Specificity]
v) [Label]
labels
     case [Q Exp]
bodies of
       [Q Exp
b] -> if Bool
sigs then Q Exp
b Q Exp -> TypeQ -> Q Exp
`sigE` [TyVarBndr Specificity] -> CxtQ -> TypeQ -> TypeQ
forallT [TyVarBndr Specificity]
vars CxtQ
context ([TypeQ] -> TypeQ
forall a. [a] -> a
head [TypeQ]
types) else Q Exp
b
       [Q Exp]
_   -> if Bool
sigs
          then [Q Exp] -> Q Exp
tupE [Q Exp]
bodies Q Exp -> TypeQ -> Q Exp
`sigE`
               [TyVarBndr Specificity] -> CxtQ -> TypeQ -> TypeQ
forallT [TyVarBndr Specificity]
vars CxtQ
context ((TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Int -> TypeQ
tupleT ([Q Exp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Exp]
bodies)) [TypeQ]
types)
          else [Q Exp] -> Q Exp
tupE [Q Exp]
bodies

-- | 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 Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest
    Char
f : String
rest       -> Char
'l' Char -> String -> String
forall a. a -> [a] -> [a]
: Char -> Char
toUpper Char
f Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest
    String
n              -> String -> String
forall a. String -> a
fclError (String
"Cannot derive label for record selector with name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n)

-- | 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 <- [Dec] -> (Dec -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Dec]
ds [Dec] -> (Dec -> [Dec]) -> [Dec]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Dec -> [Dec]
labels) ((String -> String)
-> Bool -> Bool -> Bool -> Bool -> Dec -> Q [Dec]
mkLabelsWithForDec String -> String
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id Bool
True Bool
False Bool
False Bool
False)
     [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Dec -> Dec
delabelize (Dec -> Dec) -> [Dec] -> [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Dec]
ds) [Dec] -> [[Dec]] -> [[Dec]]
forall a. a -> [a] -> [a]
: [[Dec]]
ls))
  where

  labels :: Dec -> [Dec]
  labels :: Dec -> [Dec]
labels Dec
dec =
    case Dec
dec of
      DataD    {} -> [Dec
dec]
      NewtypeD {} -> [Dec
dec]
      Dec
_           -> []

  delabelize :: Dec -> Dec
  delabelize :: Dec -> Dec
delabelize Dec
dec =
    case Dec
dec of
#if MIN_VERSION_template_haskell(2,11,0)
      DataD    Cxt
ctx Name
nm [TyVarBndr Specificity]
vars Maybe Kind
mk [Con]
cs [DerivClause]
ns -> Cxt
-> Name
-> [TyVarBndr Specificity]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD    Cxt
ctx Name
nm [TyVarBndr Specificity]
vars Maybe Kind
mk (Con -> Con
con (Con -> Con) -> [Con] -> [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con]
cs) [DerivClause]
ns
      NewtypeD Cxt
ctx Name
nm [TyVarBndr Specificity]
vars Maybe Kind
mk Con
c  [DerivClause]
ns -> Cxt
-> Name
-> [TyVarBndr Specificity]
-> Maybe Kind
-> Con
-> [DerivClause]
-> Dec
NewtypeD Cxt
ctx Name
nm [TyVarBndr Specificity]
vars Maybe Kind
mk (Con -> Con
con Con
c)      [DerivClause]
ns
#else
      DataD    ctx nm vars cs ns -> DataD    ctx nm vars (con <$> cs) ns
      NewtypeD ctx nm vars c  ns -> NewtypeD ctx nm vars (con c)      ns
#endif
      Dec
rest                       -> Dec
rest
    where con :: Con -> Con
con (RecC Name
n [VarBangType]
vst) = Name -> [BangType] -> Con
NormalC Name
n ((VarBangType -> BangType) -> [VarBangType] -> [BangType]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_, Bang
s, Kind
t) -> (Bang
s, Kind
t)) [VarBangType]
vst)
#if MIN_VERSION_template_haskell(2,11,0)
          con (RecGadtC [Name]
ns [VarBangType]
vst Kind
ty) = [Name] -> [BangType] -> Kind -> Con
GadtC [Name]
ns ((VarBangType -> BangType) -> [VarBangType] -> [BangType]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_, Bang
s, Kind
t) -> (Bang
s, Kind
t)) [VarBangType]
vst) Kind
ty
#endif
          con Con
c            = Con
c

-------------------------------------------------------------------------------
-- 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
(Field c -> Field c -> Bool)
-> (Field c -> Field c -> Bool) -> Eq (Field c)
forall c. Eq c => Field c -> Field c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Field c -> Field c -> Bool
$c/= :: forall c. Eq c => Field c -> Field c -> Bool
== :: Field c -> Field c -> Bool
$c== :: forall c. Eq c => Field c -> Field c -> Bool
Eq, a -> Field b -> Field a
(a -> b) -> Field a -> Field b
(forall a b. (a -> b) -> Field a -> Field b)
-> (forall a b. a -> Field b -> Field a) -> Functor Field
forall a b. a -> Field b -> Field a
forall a b. (a -> b) -> Field a -> Field b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Field b -> Field a
$c<$ :: forall a b. a -> Field b -> Field a
fmap :: (a -> b) -> Field a -> Field b
$cfmap :: forall a b. (a -> b) -> Field a -> Field b
Functor, Field a -> Bool
(a -> m) -> Field a -> m
(a -> b -> b) -> b -> Field a -> b
(forall m. Monoid m => Field m -> m)
-> (forall m a. Monoid m => (a -> m) -> Field a -> m)
-> (forall m a. Monoid m => (a -> m) -> Field a -> m)
-> (forall a b. (a -> b -> b) -> b -> Field a -> b)
-> (forall a b. (a -> b -> b) -> b -> Field a -> b)
-> (forall b a. (b -> a -> b) -> b -> Field a -> b)
-> (forall b a. (b -> a -> b) -> b -> Field a -> b)
-> (forall a. (a -> a -> a) -> Field a -> a)
-> (forall a. (a -> a -> a) -> Field a -> a)
-> (forall a. Field a -> [a])
-> (forall a. Field a -> Bool)
-> (forall a. Field a -> Int)
-> (forall a. Eq a => a -> Field a -> Bool)
-> (forall a. Ord a => Field a -> a)
-> (forall a. Ord a => Field a -> a)
-> (forall a. Num a => Field a -> a)
-> (forall a. Num a => Field a -> a)
-> Foldable Field
forall a. Eq a => a -> Field a -> Bool
forall a. Num a => Field a -> a
forall a. Ord a => Field a -> a
forall m. Monoid m => Field m -> m
forall a. Field a -> Bool
forall a. Field a -> Int
forall a. Field a -> [a]
forall a. (a -> a -> a) -> Field a -> a
forall m a. Monoid m => (a -> m) -> Field a -> m
forall b a. (b -> a -> b) -> b -> Field a -> b
forall a b. (a -> b -> b) -> b -> Field a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: Field a -> a
$cproduct :: forall a. Num a => Field a -> a
sum :: Field a -> a
$csum :: forall a. Num a => Field a -> a
minimum :: Field a -> a
$cminimum :: forall a. Ord a => Field a -> a
maximum :: Field a -> a
$cmaximum :: forall a. Ord a => Field a -> a
elem :: a -> Field a -> Bool
$celem :: forall a. Eq a => a -> Field a -> Bool
length :: Field a -> Int
$clength :: forall a. Field a -> Int
null :: Field a -> Bool
$cnull :: forall a. Field a -> Bool
toList :: Field a -> [a]
$ctoList :: forall a. Field a -> [a]
foldl1 :: (a -> a -> a) -> Field a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Field a -> a
foldr1 :: (a -> a -> a) -> Field a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Field a -> a
foldl' :: (b -> a -> b) -> b -> Field a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Field a -> b
foldl :: (b -> a -> b) -> b -> Field a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Field a -> b
foldr' :: (a -> b -> b) -> b -> Field a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Field a -> b
foldr :: (a -> b -> b) -> b -> Field a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Field a -> b
foldMap' :: (a -> m) -> Field a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Field a -> m
foldMap :: (a -> m) -> Field a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Field a -> m
fold :: Field m -> m
$cfold :: forall m. Monoid m => Field m -> m
Foldable)

type Subst = [(Type, Type)]

data Context = Context
  Int                  -- Field index.
  Name                 -- Constructor name.
  Con                  -- Constructor.
  deriving (Context -> Context -> Bool
(Context -> Context -> Bool)
-> (Context -> Context -> Bool) -> Eq Context
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Context -> Context -> Bool
$c/= :: Context -> Context -> Bool
== :: Context -> Context -> Bool
$c== :: Context -> Context -> Bool
Eq, Int -> Context -> String -> String
[Context] -> String -> String
Context -> String
(Int -> Context -> String -> String)
-> (Context -> String)
-> ([Context] -> String -> String)
-> Show Context
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Context] -> String -> String
$cshowList :: [Context] -> String -> String
show :: Context -> String
$cshow :: Context -> String
showsPrec :: Int -> Context -> String -> String
$cshowsPrec :: Int -> Context -> String -> String
Show)

data Typing = Typing
  Bool                 -- 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  <- [Label] -> (Label -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Label]
labels ((Label -> Q [Dec]) -> Q [[Dec]])
-> (Label -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \Label
l ->
       case Label
l of
         LabelExpr {} -> [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
         LabelDecl Name
n Q Dec
i [TyVarBndr Specificity]
v CxtQ
c TypeQ
t Q Exp
b ->
           do [Dec]
bdy <- Dec -> [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [ClauseQ] -> Q Dec
funD Name
n [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (Q Exp -> BodyQ
normalB Q Exp
b) []]
              [Dec]
prg <- if Bool
inl then Dec -> [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
i else [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
              [Dec]
typ <- if Bool
sigs
                       then Dec -> [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TypeQ -> Q Dec
sigD Name
n ([TyVarBndr Specificity] -> CxtQ -> TypeQ -> TypeQ
forallT [TyVarBndr Specificity]
v CxtQ
c TypeQ
t)
                       else [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
              [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]
prg, [Dec]
typ, [Dec]
bdy])
     [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decls)

-- 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 Specificity]
vars) =
          case Dec
dec of
#if MIN_VERSION_template_haskell(2,11,0)
            DataD    Cxt
_ Name
n [TyVarBndr Specificity]
vs Maybe Kind
_ [Con]
cs [DerivClause]
_ -> (Name
n, [Con]
cs,  [TyVarBndr Specificity]
vs)
            NewtypeD Cxt
_ Name
n [TyVarBndr Specificity]
vs Maybe Kind
_ Con
c  [DerivClause]
_ -> (Name
n, [Con
c], [TyVarBndr Specificity]
vs)
#else
            DataD    _ n vs cs _ -> (n, cs,  vs)
            NewtypeD _ n vs c  _ -> (n, [c], vs)
#endif
            Dec
_ -> String -> (Name, [Con], [TyVarBndr Specificity])
forall a. String -> a
fclError String
"Can only derive labels for datatypes and newtypes."

        -- We are only interested in lenses of record constructors.
        fields :: [Field ([Context], Subst)]
fields = (String -> String)
-> [TyVarBndr Specificity] -> [Con] -> [Field ([Context], Subst)]
forall a.
(String -> String)
-> [TyVarBndr Specificity] -> [Con] -> [Field ([Context], Subst)]
groupFields String -> String
mk [TyVarBndr Specificity]
vars [Con]
cons

    [Field ([Context], Subst)]
-> (Field ([Context], Subst) -> Q Label) -> Q [Label]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Field ([Context], Subst)]
fields ((Field ([Context], Subst) -> Q Label) -> Q [Label])
-> (Field ([Context], Subst) -> Q Label) -> Q [Label]
forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Name
-> [TyVarBndr Specificity]
-> [Con]
-> Field ([Context], Subst)
-> Q Label
generateLabel Bool
failing Bool
concrete Name
name [TyVarBndr Specificity]
vars [Con]
cons

groupFields :: (String -> String) -> [TyVarBndr a] -> [Con]
  -> [Field ([Context], Subst)]
groupFields :: (String -> String)
-> [TyVarBndr Specificity] -> [Con] -> [Field ([Context], Subst)]
groupFields String -> String
mk [TyVarBndr Specificity]
vs
  = (Field ([Context], Subst) -> Field ([Context], Subst))
-> [Field ([Context], Subst)] -> [Field ([Context], Subst)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String)
-> Field ([Context], Subst) -> Field ([Context], Subst)
forall c. (String -> String) -> Field c -> Field c
rename String -> String
mk)
  ([Field ([Context], Subst)] -> [Field ([Context], Subst)])
-> ([Con] -> [Field ([Context], Subst)])
-> [Con]
-> [Field ([Context], Subst)]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ([Field (Context, Subst)] -> [Field ([Context], Subst)])
-> [[Field (Context, Subst)]] -> [Field ([Context], Subst)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\[Field (Context, Subst)]
fs -> let vals :: [(Context, Subst)]
vals  = [[(Context, Subst)]] -> [(Context, Subst)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Field (Context, Subst) -> [(Context, Subst)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Field (Context, Subst) -> [(Context, Subst)])
-> [Field (Context, Subst)] -> [[(Context, Subst)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field (Context, Subst)]
fs)
                          cons :: [Context]
cons  = (Context, Subst) -> Context
forall a b. (a, b) -> a
fst ((Context, Subst) -> Context) -> [(Context, Subst)] -> [Context]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Context, Subst)]
vals
                          subst :: Subst
subst = [Subst] -> Subst
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Context, Subst) -> Subst
forall a b. (a, b) -> b
snd ((Context, Subst) -> Subst) -> [(Context, Subst)] -> [Subst]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Context, Subst)]
vals)
                       in [Field ([Context], Subst)] -> [Field ([Context], Subst)]
forall a. Eq a => [a] -> [a]
nub (((Context, Subst) -> ([Context], Subst))
-> Field (Context, Subst) -> Field ([Context], Subst)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Context], Subst) -> (Context, Subst) -> ([Context], Subst)
forall a b. a -> b -> a
const ([Context]
cons, Subst
subst)) (Field (Context, Subst) -> Field ([Context], Subst))
-> [Field (Context, Subst)] -> [Field ([Context], Subst)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field (Context, Subst)]
fs)
              )
  ([[Field (Context, Subst)]] -> [Field ([Context], Subst)])
-> ([Con] -> [[Field (Context, Subst)]])
-> [Con]
-> [Field ([Context], Subst)]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Field (Context, Subst) -> Field (Context, Subst) -> Bool)
-> [Field (Context, Subst)] -> [[Field (Context, Subst)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy Field (Context, Subst) -> Field (Context, Subst) -> Bool
forall c c. Field c -> Field c -> Bool
eq
  ([Field (Context, Subst)] -> [[Field (Context, Subst)]])
-> ([Con] -> [Field (Context, Subst)])
-> [Con]
-> [[Field (Context, Subst)]]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Field (Context, Subst) -> Field (Context, Subst) -> Ordering)
-> [Field (Context, Subst)] -> [Field (Context, Subst)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Field (Context, Subst) -> Maybe Name)
-> Field (Context, Subst) -> Field (Context, Subst) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Field (Context, Subst) -> Maybe Name
forall c. Field c -> Maybe Name
name)
  ([Field (Context, Subst)] -> [Field (Context, Subst)])
-> ([Con] -> [Field (Context, Subst)])
-> [Con]
-> [Field (Context, Subst)]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Con -> [Field (Context, Subst)])
-> [Con] -> [Field (Context, Subst)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([TyVarBndr Specificity] -> Con -> [Field (Context, Subst)]
forall a.
[TyVarBndr Specificity] -> Con -> [Field (Context, Subst)]
constructorFields [TyVarBndr Specificity]
vs)
  where name :: Field c -> Maybe Name
name (Field Maybe Name
n Bool
_ Kind
_ c
_) = Maybe Name
n
        eq :: Field c -> Field c -> Bool
eq Field c
f Field c
g = Bool
False Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
`fromMaybe` (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Name -> Name -> Bool) -> Maybe Name -> Maybe (Name -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Field c -> Maybe Name
forall c. Field c -> Maybe Name
name Field c
f Maybe (Name -> Bool) -> Maybe Name -> Maybe Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Field c -> Maybe Name
forall c. Field c -> Maybe Name
name Field c
g)
        rename :: (String -> String) -> Field c -> Field c
rename String -> String
f (Field Maybe Name
n Bool
a Kind
b c
c) =
          Maybe Name -> Bool -> Kind -> c -> Field c
forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field (String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> String
f (String -> String) -> (Name -> String) -> Name -> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> String
nameBase (Name -> Name) -> Maybe Name -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Name
n) Bool
a Kind
b c
c

constructorFields :: [TyVarBndr a] -> Con -> [Field (Context, Subst)]
constructorFields :: [TyVarBndr Specificity] -> Con -> [Field (Context, Subst)]
constructorFields [TyVarBndr Specificity]
vs Con
con =

  case Con
con of

    NormalC Name
c [BangType]
fs -> (Int, BangType) -> Field (Context, Subst)
forall a. (Int, BangType) -> Field (Context, [a])
one ((Int, BangType) -> Field (Context, Subst))
-> [(Int, BangType)] -> [Field (Context, Subst)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> [BangType] -> [(Int, BangType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [BangType]
fs
      where one :: (Int, BangType) -> Field (Context, [a])
one (Int
i, f :: BangType
f@(Bang
_, Kind
ty)) = Maybe Name
-> Bool -> Kind -> (Context, [a]) -> Field (Context, [a])
forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field Maybe Name
forall a. Maybe a
Nothing Bool
mono Kind
ty (Int -> Name -> Con -> Context
Context Int
i Name
c Con
con, [])
              where fsTys :: [[Name]]
fsTys = (BangType -> [Name]) -> [BangType] -> [[Name]]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> [Name]
typeVariables (Kind -> [Name]) -> (BangType -> Kind) -> BangType -> [Name]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. BangType -> Kind
forall a b. (a, b) -> b
snd) (BangType -> [BangType] -> [BangType]
forall a. Eq a => a -> [a] -> [a]
delete BangType
f [BangType]
fs)
                    mono :: Bool
mono  = (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
x -> ([Name] -> Bool) -> [[Name]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Name
x) [[Name]]
fsTys) (Kind -> [Name]
typeVariables Kind
ty)

    RecC Name
c [VarBangType]
fs -> (Int, VarBangType) -> Field (Context, Subst)
forall a. (Int, VarBangType) -> Field (Context, [a])
one ((Int, VarBangType) -> Field (Context, Subst))
-> [(Int, VarBangType)] -> [Field (Context, Subst)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> [VarBangType] -> [(Int, VarBangType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [VarBangType]
fs
      where one :: (Int, VarBangType) -> Field (Context, [a])
one (Int
i, f :: VarBangType
f@(Name
n, Bang
_, Kind
ty)) = Maybe Name
-> Bool -> Kind -> (Context, [a]) -> Field (Context, [a])
forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n) Bool
mono Kind
ty (Int -> Name -> Con -> Context
Context Int
i Name
c Con
con, [])
              where fsTys :: [[Name]]
fsTys = (VarBangType -> [Name]) -> [VarBangType] -> [[Name]]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> [Name]
typeVariables (Kind -> [Name]) -> (VarBangType -> Kind) -> VarBangType -> [Name]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. VarBangType -> Kind
forall a b c. (a, b, c) -> c
trd) (VarBangType -> [VarBangType] -> [VarBangType]
forall a. Eq a => a -> [a] -> [a]
delete VarBangType
f [VarBangType]
fs)
                    mono :: Bool
mono  = (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
x -> ([Name] -> Bool) -> [[Name]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Name
x) [[Name]]
fsTys) (Kind -> [Name]
typeVariables Kind
ty)

    InfixC BangType
a Name
c BangType
b -> (Int, BangType) -> Field (Context, Subst)
forall a a. (Int, (a, Kind)) -> Field (Context, [a])
one ((Int, BangType) -> Field (Context, Subst))
-> [(Int, BangType)] -> [Field (Context, Subst)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int
0, BangType
a), (Int
1, BangType
b)]
      where one :: (Int, (a, Kind)) -> Field (Context, [a])
one (Int
i, (a
_, Kind
ty)) = Maybe Name
-> Bool -> Kind -> (Context, [a]) -> Field (Context, [a])
forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field Maybe Name
forall a. Maybe a
Nothing Bool
mono Kind
ty (Int -> Name -> Con -> Context
Context Int
i Name
c Con
con, [])
              where fsTys :: [[Name]]
fsTys = (BangType -> [Name]) -> [BangType] -> [[Name]]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> [Name]
typeVariables (Kind -> [Name]) -> (BangType -> Kind) -> BangType -> [Name]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. BangType -> Kind
forall a b. (a, b) -> b
snd) [BangType
a, BangType
b]
                    mono :: Bool
mono  = (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
x -> ([Name] -> Bool) -> [[Name]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Name
x) [[Name]]
fsTys) (Kind -> [Name]
typeVariables Kind
ty)

    ForallC [TyVarBndr Specificity]
x Cxt
y Con
v -> Field (Context, Subst) -> Field (Context, Subst)
setEqs (Field (Context, Subst) -> Field (Context, Subst))
-> [Field (Context, Subst)] -> [Field (Context, Subst)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr Specificity] -> Con -> [Field (Context, Subst)]
forall a.
[TyVarBndr Specificity] -> Con -> [Field (Context, Subst)]
constructorFields [TyVarBndr Specificity]
vs Con
v
#if MIN_VERSION_template_haskell(2,10,0)
      where eqs :: Subst
eqs = [ (Kind
a, Kind
b) | AppT (AppT Kind
EqualityT Kind
a) Kind
b <- Cxt
y ]
#else
      where eqs = [ (a, b) | EqualP a b <- y ]
#endif
            setEqs :: Field (Context, Subst) -> Field (Context, Subst)
setEqs (Field Maybe Name
a Bool
b Kind
c (Context, Subst)
d) = Maybe Name
-> Bool -> Kind -> (Context, Subst) -> Field (Context, Subst)
forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field Maybe Name
a Bool
b Kind
c ((Context -> Context) -> (Context, Subst) -> (Context, Subst)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Context -> Context
upd ((Context, Subst) -> (Context, Subst))
-> ((Context, Subst) -> (Context, Subst))
-> (Context, Subst)
-> (Context, Subst)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Subst -> Subst) -> (Context, Subst) -> (Context, Subst)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Subst
eqs Subst -> Subst -> Subst
forall a. [a] -> [a] -> [a]
++) ((Context, Subst) -> (Context, Subst))
-> (Context, Subst) -> (Context, Subst)
forall a b. (a -> b) -> a -> b
$ (Context, Subst)
d)
            upd :: Context -> Context
upd (Context Int
a Name
b Con
c) = Int -> Name -> Con -> Context
Context Int
a Name
b ([TyVarBndr Specificity] -> Cxt -> Con -> Con
ForallC [TyVarBndr Specificity]
x Cxt
y Con
c)
#if MIN_VERSION_template_haskell(2,11,0)
    GadtC [Name]
cs [BangType]
fs Kind
resTy -> (Name -> [Field (Context, Subst)])
-> [Name] -> [Field (Context, Subst)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Name
c -> Name -> (Int, BangType) -> Field (Context, Subst)
one Name
c ((Int, BangType) -> Field (Context, Subst))
-> [(Int, BangType)] -> [Field (Context, Subst)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> [BangType] -> [(Int, BangType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [BangType]
fs) [Name]
cs
      where one :: Name -> (Int, BangType) -> Field (Context, Subst)
one Name
c (Int
i, f :: BangType
f@(Bang
_, Kind
ty)) = Maybe Name
-> Bool -> Kind -> (Context, Subst) -> Field (Context, Subst)
forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field Maybe Name
forall a. Maybe a
Nothing Bool
mono Kind
ty (Int -> Name -> Con -> Context
Context Int
i Name
c Con
con, [TyVarBndr Specificity] -> Kind -> Subst
forall a. [TyVarBndr Specificity] -> Kind -> Subst
mkSubst [TyVarBndr Specificity]
vs Kind
resTy)
              where fsTys :: [[Name]]
fsTys = (BangType -> [Name]) -> [BangType] -> [[Name]]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> [Name]
typeVariables (Kind -> [Name]) -> (BangType -> Kind) -> BangType -> [Name]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. BangType -> Kind
forall a b. (a, b) -> b
snd) (BangType -> [BangType] -> [BangType]
forall a. Eq a => a -> [a] -> [a]
delete BangType
f [BangType]
fs)
                    mono :: Bool
mono  = (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
x -> ([Name] -> Bool) -> [[Name]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Name
x) [[Name]]
fsTys) (Kind -> [Name]
typeVariables Kind
ty)
    RecGadtC [Name]
cs [VarBangType]
fs Kind
resTy -> (Name -> [Field (Context, Subst)])
-> [Name] -> [Field (Context, Subst)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Name
c -> Name -> (Int, VarBangType) -> Field (Context, Subst)
one Name
c ((Int, VarBangType) -> Field (Context, Subst))
-> [(Int, VarBangType)] -> [Field (Context, Subst)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> [VarBangType] -> [(Int, VarBangType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [VarBangType]
fs) [Name]
cs
      where one :: Name -> (Int, VarBangType) -> Field (Context, Subst)
one Name
c (Int
i, f :: VarBangType
f@(Name
n, Bang
_, Kind
ty)) = Maybe Name
-> Bool -> Kind -> (Context, Subst) -> Field (Context, Subst)
forall c. Maybe Name -> Bool -> Kind -> c -> Field c
Field (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n) Bool
mono Kind
ty (Int -> Name -> Con -> Context
Context Int
i Name
c Con
con, [TyVarBndr Specificity] -> Kind -> Subst
forall a. [TyVarBndr Specificity] -> Kind -> Subst
mkSubst [TyVarBndr Specificity]
vs Kind
resTy)
              where fsTys :: [[Name]]
fsTys = (VarBangType -> [Name]) -> [VarBangType] -> [[Name]]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> [Name]
typeVariables (Kind -> [Name]) -> (VarBangType -> Kind) -> VarBangType -> [Name]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. VarBangType -> Kind
forall a b c. (a, b, c) -> c
trd) (VarBangType -> [VarBangType] -> [VarBangType]
forall a. Eq a => a -> [a] -> [a]
delete VarBangType
f [VarBangType]
fs)
                    mono :: Bool
mono  = (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
x -> ([Name] -> Bool) -> [[Name]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Name
x) [[Name]]
fsTys) (Kind -> [Name]
typeVariables Kind
ty)

mkSubst :: [TyVarBndr a] -> Type -> Subst
mkSubst :: [TyVarBndr Specificity] -> Kind -> Subst
mkSubst [TyVarBndr Specificity]
vars Kind
t = [TyVarBndr Specificity] -> Kind -> Subst
forall a. [TyVarBndr Specificity] -> Kind -> Subst
go ([TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. [a] -> [a]
reverse [TyVarBndr Specificity]
vars) Kind
t
  where
    go :: [TyVarBndr Specificity] -> Kind -> Subst
go [] Kind
_ = []
    go (TyVarBndr Specificity
v:[TyVarBndr Specificity]
vs) (AppT Kind
t1 Kind
t2) = (TyVarBndr Specificity -> Kind
forall a. TyVarBndr Specificity -> Kind
typeFromBinder TyVarBndr Specificity
v, Kind
t2) (Kind, Kind) -> Subst -> Subst
forall a. a -> [a] -> [a]
: [TyVarBndr Specificity] -> Kind -> Subst
go [TyVarBndr Specificity]
vs Kind
t1
    go [TyVarBndr Specificity]
_  Kind
_ = String -> Subst
forall a. String -> a
fclError String
"Non-AppT with type variables in mkSubst. Please report this as a bug for fclabels."
#endif

prune :: [Context] -> [Con] -> [Con]
prune :: [Context] -> [Con] -> [Con]
prune [Context]
contexts [Con]
allCons =
  case [Context]
contexts of
    (Context Int
_ Name
_ Con
con) : [Context]
_
       -> (Con -> Bool) -> [Con] -> [Con]
forall a. (a -> Bool) -> [a] -> [a]
filter (Con -> Con -> Bool
unifiableCon Con
con) [Con]
allCons
    [] -> []

unifiableCon :: Con -> Con -> Bool
unifiableCon :: Con -> Con -> Bool
unifiableCon Con
a Con
b = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Kind -> Kind -> Bool) -> Cxt -> Cxt -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Kind -> Kind -> Bool
unifiable (Con -> Cxt
indices Con
a) (Con -> Cxt
indices Con
b))
  where indices :: Con -> Cxt
indices Con
con =
          case Con
con of
            NormalC {}      -> []
            RecC    {}      -> []
            InfixC  {}      -> []
#if MIN_VERSION_template_haskell(2,11,0)
            ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
ty  -> Con -> Cxt
indices Con
ty
#elif MIN_VERSION_template_haskell(2,10,0)
            ForallC _ x _   -> [ c | AppT (AppT EqualityT _) c <- x ]
#else
            ForallC _ x _   -> [ c | EqualP _ c <- x ]
#endif
#if MIN_VERSION_template_haskell(2,11,0)
            GadtC [Name]
_ [BangType]
_ Kind
ty    -> Kind -> Cxt
conIndices Kind
ty
            RecGadtC [Name]
_ [VarBangType]
_ Kind
ty -> Kind -> Cxt
conIndices Kind
ty
         where
           conIndices :: Kind -> Cxt
conIndices (AppT (ConT Name
_) Kind
ty) = [Kind
ty]
           conIndices (AppT Kind
rest     Kind
ty) = Kind -> Cxt
conIndices Kind
rest Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ [Kind
ty]
           conIndices Kind
_                  = String -> Cxt
forall a. String -> a
fclError String
"Non-AppT in conIndices. Please report this as a bug for fclabels."
#endif

unifiable :: Type -> Type -> Bool
unifiable :: Kind -> Kind -> Bool
unifiable Kind
x Kind
y =
  case (Kind
x, Kind
y) of
    ( VarT Name
_        ,      Kind
_        ) -> Bool
True
    ( Kind
_             , VarT Name
_        ) -> Bool
True
    ( AppT Kind
a Kind
b      , AppT Kind
c Kind
d      ) -> Kind -> Kind -> Bool
unifiable Kind
a Kind
c Bool -> Bool -> Bool
&& Kind -> Kind -> Bool
unifiable Kind
b Kind
d
    ( SigT Kind
t Kind
k      , SigT Kind
s Kind
j      ) -> Kind -> Kind -> Bool
unifiable Kind
t Kind
s Bool -> Bool -> Bool
&& Kind
k Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
j
    ( ForallT [TyVarBndr Specificity]
_ Cxt
_ Kind
t , ForallT [TyVarBndr Specificity]
_ Cxt
_ Kind
s ) -> Kind -> Kind -> Bool
unifiable Kind
t Kind
s
    ( Kind
a             , Kind
b             ) -> Kind
a Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
b

generateLabel
  :: Bool
  -> Bool
  -> Name
  -> [TyVarBndr ()]
  -> [Con]
  -> Field ([Context], Subst)
  -> Q Label

generateLabel :: Bool
-> Bool
-> Name
-> [TyVarBndr Specificity]
-> [Con]
-> Field ([Context], Subst)
-> Q Label
generateLabel Bool
failing Bool
concrete Name
datatype [TyVarBndr Specificity]
dtVars [Con]
allCons
              field :: Field ([Context], Subst)
field@(Field Maybe Name
name Bool
forcedMono Kind
fieldtype ([Context]
contexts, Subst
subst)) =

  do let total :: Bool
total = [Context] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Context]
contexts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Con] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Context] -> [Con] -> [Con]
prune [Context]
contexts [Con]
allCons)

     (Typing Bool
mono TypeQ
tyI TypeQ
tyO [TyVarBndr Specificity]
_)
        <- Bool
-> Kind -> Name -> [TyVarBndr Specificity] -> Subst -> Q Typing
computeTypes Bool
forcedMono Kind
fieldtype Name
datatype [TyVarBndr Specificity]
dtVars Subst
subst

     let cat :: TypeQ
cat     = Name -> TypeQ
varT (String -> Name
mkName String
"cat")
         failE :: Q Exp
failE   = if Bool
failing
                   then [| failArrow |]
                   else [| zeroArrow |]
         getT :: Q Exp
getT    = [| arr $(getter failing total field) |]
         putT :: Q Exp
putT    = [| arr $(setter failing total field) |]
         getP :: Q Exp
getP    = [| $(failE) ||| id <<< $getT |]
         putP :: Q Exp
putP    = [| $(failE) ||| id <<< $putT |]
         failP :: TypeQ
failP   = if Bool
failing
                   then Name -> [TypeQ] -> TypeQ
classP ''ArrowFail [ [t| String |], TypeQ
cat]
                   else Name -> [TypeQ] -> TypeQ
classP ''ArrowZero [TypeQ
cat]
         ctx :: CxtQ
ctx     = if Bool
total
                   then [TypeQ] -> CxtQ
cxt [ Name -> [TypeQ] -> TypeQ
classP ''ArrowApply  [TypeQ
cat] ]
                   else [TypeQ] -> CxtQ
cxt [ Name -> [TypeQ] -> TypeQ
classP ''ArrowChoice [TypeQ
cat]
                            , Name -> [TypeQ] -> TypeQ
classP ''ArrowApply  [TypeQ
cat]
                            , TypeQ
failP
                            ]
         body :: Q Exp
body    = if Bool
total
                   then [| Poly.point $ Point $getT (modifier $getT $putT) |]
                   else [| Poly.point $ Point $getP (modifier $getP $putP) |]
         cont :: CxtQ
cont    = if Bool
concrete
                   then [TypeQ] -> CxtQ
cxt []
                   else CxtQ
ctx
         partial :: TypeQ
partial = if Bool
failing
                   then [t| Failing String |]
                   else [t| Partial |]
         concTy :: TypeQ
concTy  = if Bool
total
                   then if Bool
mono
                        then [t| Mono.Lens Total $tyI $tyO |]
                        else [t| Poly.Lens Total $tyI $tyO |]
                   else if Bool
mono
                        then [t| Mono.Lens $partial $tyI $tyO |]
                        else [t| Poly.Lens $partial $tyI $tyO |]
         ty :: TypeQ
ty      = if Bool
concrete
                   then TypeQ
concTy
                   else if Bool
mono
                        then [t| Mono.Lens $cat $tyI $tyO |]
                        else [t| Poly.Lens $cat $tyI $tyO |]

     [TyVarBndr Specificity]
tvs <- [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. Eq a => [a] -> [a]
nub ([TyVarBndr Specificity] -> [TyVarBndr Specificity])
-> (Kind -> [TyVarBndr Specificity])
-> Kind
-> [TyVarBndr Specificity]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Kind -> [TyVarBndr Specificity]
binderFromType (Kind -> [TyVarBndr Specificity])
-> TypeQ -> Q [TyVarBndr Specificity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ
ty
     Label -> Q Label
forall (m :: * -> *) a. Monad m => a -> m a
return (Label -> Q Label) -> Label -> Q Label
forall a b. (a -> b) -> a -> b
$
       case Maybe Name
name of
         Maybe Name
Nothing -> [TyVarBndr Specificity] -> CxtQ -> TypeQ -> Q Exp -> Label
LabelExpr [TyVarBndr Specificity]
tvs CxtQ
cont TypeQ
ty Q Exp
body
         Just Name
n  ->

#if MIN_VERSION_template_haskell(2,8,0)
           -- 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 (Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma -> Dec
PragmaD Pragma
inline)) [TyVarBndr Specificity]
tvs CxtQ
cont TypeQ
ty Q Exp
body

-- 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 :: cat f o -> cat (i, f) g -> cat (cat o i, f) g
modifier cat f o
g cat (i, f) g
m = cat (i, f) g
m cat (i, f) g -> cat (cat o i, f) (i, f) -> cat (cat o i, f) g
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. cat (cat o i, o) i -> cat ((cat o i, o), f) (i, f)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first cat (cat o i, o) i
forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app cat ((cat o i, o), f) (i, f)
-> cat (cat o i, f) ((cat o i, o), f) -> cat (cat o i, f) (i, f)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((cat o i, (f, o)) -> ((cat o i, o), f))
-> cat (cat o i, (f, o)) ((cat o i, o), f)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(cat o i
n, (f
f, o
o)) -> ((cat o i
n, o
o), f
f)) cat (cat o i, (f, o)) ((cat o i, o), f)
-> cat (cat o i, f) (cat o i, (f, o))
-> cat (cat o i, f) ((cat o i, o), f)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. cat f (f, o) -> cat (cat o i, f) (cat o i, (f, o))
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (cat f f
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id cat f f -> cat f o -> cat f (f, o)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& cat f o
g)
{-# INLINE modifier #-}

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

getter :: Bool -> Bool -> Field ([Context], Subst) -> Q Exp
getter :: Bool -> Bool -> Field ([Context], Subst) -> Q Exp
getter Bool
failing Bool
total (Field Maybe Name
mn Bool
_ Kind
_ ([Context]
cons, Subst
_)) =
  do let pt :: Name
pt = String -> Name
mkName String
"f"
         nm :: Q Exp
nm = Q Exp -> (Name -> Q Exp) -> Maybe Name -> Q Exp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Q Exp] -> Q Exp
tupE []) (Lit -> Q Exp
litE (Lit -> Q Exp) -> (Name -> Lit) -> Name -> Q Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Lit
StringL (String -> Lit) -> (Name -> String) -> Name -> Lit
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> String
nameBase) (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
failing Maybe () -> Maybe Name -> Maybe Name
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Name
mn)
         wild :: [MatchQ]
wild = if Bool
total then [] else [PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
wildP (Q Exp -> BodyQ
normalB [| Left $(nm) |]) []]
         rght :: Q Exp -> Q Exp
rght = if Bool
total then Q Exp -> Q Exp
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id else Q Exp -> Q Exp -> Q Exp
appE [| Right |]
         mkCase :: Context -> [MatchQ]
mkCase (Context Int
i Name
_ Con
c) = ((PatQ, Q Exp) -> MatchQ) -> [(PatQ, Q Exp)] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(PatQ
pat, Q Exp
var) -> PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
pat (Q Exp -> BodyQ
normalB (Q Exp -> Q Exp
rght Q Exp
var)) []) (Int -> Con -> [(PatQ, Q Exp)]
case1 Int
i Con
c)
     [PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
pt]
          (Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
pt) ((Context -> [MatchQ]) -> [Context] -> [MatchQ]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Context -> [MatchQ]
mkCase [Context]
cons [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. [a] -> [a] -> [a]
++ [MatchQ]
wild))
  where
  case1 :: Int -> Con -> [(Q Pat, Q Exp)]
  case1 :: Int -> Con -> [(PatQ, Q Exp)]
case1 Int
i Con
con =
    case Con
con of
      NormalC  Name
c  [BangType]
fs   -> [[BangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [BangType]
fs Name
c]
      RecC     Name
c  [VarBangType]
fs   -> [[VarBangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [VarBangType]
fs Name
c]
      InfixC   BangType
_  Name
c  BangType
_ -> [(PatQ -> Name -> PatQ -> PatQ
infixP ([PatQ]
pats [PatQ] -> Int -> PatQ
forall a. [a] -> Int -> a
!! Int
0) Name
c ([PatQ]
pats [PatQ] -> Int -> PatQ
forall a. [a] -> Int -> a
!! Int
1), Q Exp
var)]
      ForallC  [TyVarBndr Specificity]
_  Cxt
_  Con
c -> Int -> Con -> [(PatQ, Q Exp)]
case1 Int
i Con
c
#if MIN_VERSION_template_haskell(2,11,0)
      GadtC    [Name]
cs [BangType]
fs Kind
_ -> (Name -> (PatQ, Q Exp)) -> [Name] -> [(PatQ, Q Exp)]
forall a b. (a -> b) -> [a] -> [b]
map ([BangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [BangType]
fs) [Name]
cs
      RecGadtC [Name]
cs [VarBangType]
fs Kind
_ -> (Name -> (PatQ, Q Exp)) -> [Name] -> [(PatQ, Q Exp)]
forall a b. (a -> b) -> [a] -> [b]
map ([VarBangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [VarBangType]
fs) [Name]
cs
#endif
    where fresh :: [Name]
fresh = String -> Name
mkName (String -> Name) -> [String] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> [String]
forall a. Eq a => a -> [a] -> [a]
delete String
"f" [String]
freshNames
          pats1 :: [PatQ]
pats1 = Name -> PatQ
varP (Name -> PatQ) -> [Name] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fresh
          pats :: [PatQ]
pats  = Int -> PatQ -> [PatQ]
forall a. Int -> a -> [a]
replicate Int
i PatQ
wildP [PatQ] -> [PatQ] -> [PatQ]
forall a. [a] -> [a] -> [a]
++ [[PatQ]
pats1 [PatQ] -> Int -> PatQ
forall a. [a] -> Int -> a
!! Int
i] [PatQ] -> [PatQ] -> [PatQ]
forall a. [a] -> [a] -> [a]
++ PatQ -> [PatQ]
forall a. a -> [a]
repeat PatQ
wildP
          var :: Q Exp
var   = Name -> Q Exp
varE ([Name]
fresh [Name] -> Int -> Name
forall a. [a] -> Int -> a
!! Int
i)
          one :: t a -> Name -> (PatQ, Q Exp)
one t a
fs Name
c = let s :: [a] -> [a]
s = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
fs) in (Name -> [PatQ] -> PatQ
conP Name
c ([PatQ] -> [PatQ]
forall a. [a] -> [a]
s [PatQ]
pats), Q Exp
var)

setter :: Bool -> Bool -> Field ([Context], Subst) -> Q Exp
setter :: Bool -> Bool -> Field ([Context], Subst) -> Q Exp
setter Bool
failing Bool
total (Field Maybe Name
mn Bool
_ Kind
_ ([Context]
cons, Subst
_)) =
  do let pt :: Name
pt = String -> Name
mkName String
"f"
         md :: Name
md = String -> Name
mkName String
"v"
         nm :: Q Exp
nm = Q Exp -> (Name -> Q Exp) -> Maybe Name -> Q Exp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Q Exp] -> Q Exp
tupE []) (Lit -> Q Exp
litE (Lit -> Q Exp) -> (Name -> Lit) -> Name -> Q Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Lit
StringL (String -> Lit) -> (Name -> String) -> Name -> Lit
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> String
nameBase) (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
failing Maybe () -> Maybe Name -> Maybe Name
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Name
mn)
         wild :: [MatchQ]
wild = if Bool
total then [] else [PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
wildP (Q Exp -> BodyQ
normalB [| Left $(nm) |]) []]
         rght :: Q Exp -> Q Exp
rght = if Bool
total then Q Exp -> Q Exp
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id else Q Exp -> Q Exp -> Q Exp
appE [| Right |]
         mkCase :: Context -> [MatchQ]
mkCase (Context Int
i Name
_ Con
c) = ((PatQ, Q Exp) -> MatchQ) -> [(PatQ, Q Exp)] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(PatQ
pat, Q Exp
var) -> PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
pat (Q Exp -> BodyQ
normalB (Q Exp -> Q Exp
rght Q Exp
var)) []) (Int -> Con -> [(PatQ, Q Exp)]
case1 Int
i Con
c)
     [PatQ] -> Q Exp -> Q Exp
lamE [[PatQ] -> PatQ
tupP [Name -> PatQ
varP Name
md, Name -> PatQ
varP Name
pt]]
          (Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
pt) ((Context -> [MatchQ]) -> [Context] -> [MatchQ]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Context -> [MatchQ]
mkCase [Context]
cons [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. [a] -> [a] -> [a]
++ [MatchQ]
wild))
  where
  case1 :: Int -> Con -> [(PatQ, Q Exp)]
case1 Int
i Con
con =
    case Con
con of
      NormalC  Name
c  [BangType]
fs   -> [[BangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [BangType]
fs Name
c]
      RecC     Name
c  [VarBangType]
fs   -> [[VarBangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [VarBangType]
fs Name
c]
      InfixC   BangType
_  Name
c  BangType
_ -> [( PatQ -> Name -> PatQ -> PatQ
infixP ([PatQ]
pats [PatQ] -> Int -> PatQ
forall a. [a] -> Int -> a
!! Int
0) Name
c ([PatQ]
pats [PatQ] -> Int -> PatQ
forall a. [a] -> Int -> a
!! Int
1)
                          , Maybe (Q Exp) -> Q Exp -> Maybe (Q Exp) -> Q Exp
infixE (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just ([Q Exp]
vars [Q Exp] -> Int -> Q Exp
forall a. [a] -> Int -> a
!! Int
0)) (Name -> Q Exp
conE Name
c) (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just ([Q Exp]
vars [Q Exp] -> Int -> Q Exp
forall a. [a] -> Int -> a
!! Int
1))
                          )
                         ]
      ForallC  [TyVarBndr Specificity]
_  Cxt
_  Con
c -> Int -> Con -> [(PatQ, Q Exp)]
case1 Int
i Con
c
#if MIN_VERSION_template_haskell(2,11,0)
      GadtC    [Name]
cs [BangType]
fs Kind
_ -> (Name -> (PatQ, Q Exp)) -> [Name] -> [(PatQ, Q Exp)]
forall a b. (a -> b) -> [a] -> [b]
map ([BangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [BangType]
fs) [Name]
cs
      RecGadtC [Name]
cs [VarBangType]
fs Kind
_ -> (Name -> (PatQ, Q Exp)) -> [Name] -> [(PatQ, Q Exp)]
forall a b. (a -> b) -> [a] -> [b]
map ([VarBangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [VarBangType]
fs) [Name]
cs
#endif
    where fresh :: [Name]
fresh     = String -> Name
mkName (String -> Name) -> [String] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> [String]
forall a. Eq a => a -> [a] -> [a]
delete String
"f" (String -> [String] -> [String]
forall a. Eq a => a -> [a] -> [a]
delete String
"v" [String]
freshNames)
          pats1 :: [PatQ]
pats1     = Name -> PatQ
varP (Name -> PatQ) -> [Name] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fresh
          pats :: [PatQ]
pats      = Int -> [PatQ] -> [PatQ]
forall a. Int -> [a] -> [a]
take Int
i [PatQ]
pats1 [PatQ] -> [PatQ] -> [PatQ]
forall a. [a] -> [a] -> [a]
++ [PatQ
wildP] [PatQ] -> [PatQ] -> [PatQ]
forall a. [a] -> [a] -> [a]
++ Int -> [PatQ] -> [PatQ]
forall a. Int -> [a] -> [a]
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [PatQ]
pats1
          vars1 :: [Q Exp]
vars1     = Name -> Q Exp
varE (Name -> Q Exp) -> [Name] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fresh
          v :: Q Exp
v         = Name -> Q Exp
varE (String -> Name
mkName String
"v")
          vars :: [Q Exp]
vars      = Int -> [Q Exp] -> [Q Exp]
forall a. Int -> [a] -> [a]
take Int
i [Q Exp]
vars1 [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ [Q Exp
v] [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ Int -> [Q Exp] -> [Q Exp]
forall a. Int -> [a] -> [a]
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Q Exp]
vars1
          apps :: Q Exp -> t (Q Exp) -> Q Exp
apps Q Exp
f t (Q Exp)
as = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> t (Q Exp) -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
appE Q Exp
f t (Q Exp)
as
          one :: t a -> Name -> (PatQ, Q Exp)
one t a
fs Name
c  = let s :: [a] -> [a]
s = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
fs) in (Name -> [PatQ] -> PatQ
conP Name
c ([PatQ] -> [PatQ]
forall a. [a] -> [a]
s [PatQ]
pats), Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *). Foldable t => Q Exp -> t (Q Exp) -> Q Exp
apps (Name -> Q Exp
conE Name
c) ([Q Exp] -> [Q Exp]
forall a. [a] -> [a]
s [Q Exp]
vars))

freshNames :: [String]
freshNames :: [String]
freshNames = (Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char
'a'..Char
'z'] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Integer -> String) -> [Integer] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char
'a'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Integer -> String) -> Integer -> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Integer -> String
forall a. Show a => a -> String
show) [Integer
0 :: Integer ..]

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

computeTypes :: Bool -> Type -> Name -> [TyVarBndr ()] -> Subst -> Q Typing
computeTypes :: Bool
-> Kind -> Name -> [TyVarBndr Specificity] -> Subst -> Q Typing
computeTypes Bool
forcedMono Kind
fieldtype Name
datatype [TyVarBndr Specificity]
dtVars_ Subst
subst =

  do let fieldVars :: [Name]
fieldVars = Kind -> [Name]
typeVariables Kind
fieldtype
         tyO :: TypeQ
tyO       = Kind -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
fieldtype
         dtTypes :: Cxt
dtTypes   = Subst -> Kind -> Kind
substitute Subst
subst (Kind -> Kind)
-> (TyVarBndr Specificity -> Kind) -> TyVarBndr Specificity -> Kind
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TyVarBndr Specificity -> Kind
forall a. TyVarBndr Specificity -> Kind
typeFromBinder (TyVarBndr Specificity -> Kind) -> [TyVarBndr Specificity] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr Specificity]
dtVars_
         dtBinders :: [TyVarBndr Specificity]
dtBinders = (Kind -> [TyVarBndr Specificity]) -> Cxt -> [TyVarBndr Specificity]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Kind -> [TyVarBndr Specificity]
binderFromType Cxt
dtTypes
         varNames :: [Name]
varNames  = TyVarBndr Specificity -> Name
nameFromBinder (TyVarBndr Specificity -> Name)
-> [TyVarBndr Specificity] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr Specificity]
dtBinders
         usedVars :: [Name]
usedVars  = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
fieldVars) [Name]
varNames
         tyI :: TypeQ
tyI       = Kind -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> TypeQ) -> Kind -> TypeQ
forall a b. (a -> b) -> a -> b
$ (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Kind -> Kind -> Kind) -> Kind -> Kind -> Kind
forall a b c. (a -> b -> c) -> b -> a -> c
flip Kind -> Kind -> Kind
AppT) (Name -> Kind
ConT Name
datatype) (Cxt -> Cxt
forall a. [a] -> [a]
reverse Cxt
dtTypes)
         pretties :: [TyVarBndr Specificity]
pretties  = (Name -> Name) -> TyVarBndr Specificity -> TyVarBndr Specificity
mapTyVarBndr Name -> Name
pretty (TyVarBndr Specificity -> TyVarBndr Specificity)
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr Specificity]
dtBinders
         mono :: Bool
mono      = Bool
forcedMono Bool -> Bool -> Bool
|| Kind -> [TyVarBndr Specificity] -> Bool
isMonomorphic Kind
fieldtype [TyVarBndr Specificity]
dtBinders

     if Bool
mono
       then Typing -> Q Typing
forall (m :: * -> *) a. Monad m => a -> m a
return (Typing -> Q Typing) -> Typing -> Q Typing
forall a b. (a -> b) -> a -> b
$ Bool -> TypeQ -> TypeQ -> [TyVarBndr Specificity] -> Typing
Typing
               Bool
mono
               (Kind -> Kind
prettyType (Kind -> Kind) -> TypeQ -> TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ
tyI)
               (Kind -> Kind
prettyType (Kind -> Kind) -> TypeQ -> TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ
tyO)
               ([TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. Eq a => [a] -> [a]
nub [TyVarBndr Specificity]
pretties)
       else
         do let names :: [String]
names = Char -> String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> String) -> String -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char
'a'..Char
'z']
                used :: [String]
used  = Name -> String
forall a. Show a => a -> String
show (Name -> String) -> (Name -> Name) -> Name -> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> Name
pretty (Name -> String) -> [Name] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
varNames
                free :: [String]
free  = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
used)) [String]
names
            [(Name, Name)]
subs <- [(Name, String)]
-> ((Name, String) -> Q (Name, Name)) -> Q [(Name, Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Name] -> [String] -> [(Name, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
usedVars [String]
free) (\(Name
a, String
b) -> (,) Name
a (Name -> (Name, Name)) -> Q Name -> Q (Name, Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName String
b)
            let rename :: Kind -> Kind
rename = (Name -> Name) -> Kind -> Kind
mapTypeVariables (\Name
a -> Name
a Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
`fromMaybe` Name -> [(Name, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
a [(Name, Name)]
subs)

            Typing -> Q Typing
forall (m :: * -> *) a. Monad m => a -> m a
return (Typing -> Q Typing) -> Typing -> Q Typing
forall a b. (a -> b) -> a -> b
$ Bool -> TypeQ -> TypeQ -> [TyVarBndr Specificity] -> Typing
Typing
              Bool
mono
              (Kind -> Kind
prettyType (Kind -> Kind) -> TypeQ -> TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| $tyI -> $(rename <$> tyI) |])
              (Kind -> Kind
prettyType (Kind -> Kind) -> TypeQ -> TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| $tyO -> $(rename <$> tyO) |])
              ([TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. Eq a => [a] -> [a]
nub ([TyVarBndr Specificity]
pretties [TyVarBndr Specificity]
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. [a] -> [a] -> [a]
++ (TyVarBndr Specificity -> TyVarBndr Specificity)
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> Name) -> TyVarBndr Specificity -> TyVarBndr Specificity
mapTyVarBndr Name -> Name
pretty)
#if MIN_VERSION_template_haskell(2,17,0)
                (flip PlainTV SpecifiedSpec . snd <$> subs)))
#else
                (Name -> TyVarBndr Specificity
PlainTV (Name -> TyVarBndr Specificity)
-> ((Name, Name) -> Name) -> (Name, Name) -> TyVarBndr Specificity
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Name, Name) -> Name
forall a b. (a, b) -> b
snd ((Name, Name) -> TyVarBndr Specificity)
-> [(Name, Name)] -> [TyVarBndr Specificity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Name)]
subs)))
#endif

isMonomorphic :: Type -> [TyVarBndr Specificity] -> Bool
isMonomorphic :: Kind -> [TyVarBndr Specificity] -> Bool
isMonomorphic Kind
field [TyVarBndr Specificity]
vars =
  let fieldVars :: [Name]
fieldVars = Kind -> [Name]
typeVariables Kind
field
      varNames :: [Name]
varNames  = TyVarBndr Specificity -> Name
nameFromBinder (TyVarBndr Specificity -> Name)
-> [TyVarBndr Specificity] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr Specificity]
vars
      usedVars :: [Name]
usedVars  = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
fieldVars) [Name]
varNames
   in [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
usedVars

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

typeVariables :: Type -> [Name]
typeVariables :: Kind -> [Name]
typeVariables = (TyVarBndr Specificity -> Name)
-> [TyVarBndr Specificity] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr Specificity -> Name
nameFromBinder ([TyVarBndr Specificity] -> [Name])
-> (Kind -> [TyVarBndr Specificity]) -> Kind -> [Name]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Kind -> [TyVarBndr Specificity]
binderFromType

typeFromBinder :: TyVarBndr a -> Type
#if MIN_VERSION_template_haskell(2,17,0)
typeFromBinder (PlainTV  tv      _) = VarT tv
#else
typeFromBinder :: TyVarBndr Specificity -> Kind
typeFromBinder (PlainTV  Name
tv       ) = Name -> Kind
VarT Name
tv
#endif

#if MIN_VERSION_template_haskell(2,17,0)
typeFromBinder (KindedTV tv _ StarT) = VarT tv
typeFromBinder (KindedTV tv _ kind) = SigT (VarT tv) kind
#elif MIN_VERSION_template_haskell(2,8,0)
typeFromBinder (KindedTV Name
tv Kind
StarT) = Name -> Kind
VarT Name
tv
typeFromBinder (KindedTV Name
tv Kind
kind) = Kind -> Kind -> Kind
SigT (Name -> Kind
VarT Name
tv) Kind
kind
#else
typeFromBinder (KindedTV tv StarK) = VarT tv
typeFromBinder (KindedTV tv kind) = SigT (VarT tv) kind
#endif

binderFromType :: Type -> [TyVarBndr Specificity]
binderFromType :: Kind -> [TyVarBndr Specificity]
binderFromType = Kind -> [TyVarBndr Specificity]
go
  where
  go :: Kind -> [TyVarBndr Specificity]
go Kind
ty =
    case Kind
ty of
      ForallT [TyVarBndr Specificity]
ts Cxt
_ Kind
_ -> [TyVarBndr Specificity]
ts
      AppT Kind
a Kind
b       -> Kind -> [TyVarBndr Specificity]
go Kind
a [TyVarBndr Specificity]
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. [a] -> [a] -> [a]
++ Kind -> [TyVarBndr Specificity]
go Kind
b
      SigT Kind
t Kind
_       -> Kind -> [TyVarBndr Specificity]
go Kind
t
#if MIN_VERSION_template_haskell(2,17,0)
      VarT n         -> [PlainTV n SpecifiedSpec]
#else
      VarT Name
n         -> [Name -> TyVarBndr Specificity
PlainTV Name
n]
#endif
      Kind
_              -> []

mapTypeVariables :: (Name -> Name) -> Type -> Type
mapTypeVariables :: (Name -> Name) -> Kind -> Kind
mapTypeVariables Name -> Name
f = Kind -> Kind
go
  where
  go :: Kind -> Kind
go Kind
ty =
    case Kind
ty of
      ForallT [TyVarBndr Specificity]
ts Cxt
a Kind
b -> [TyVarBndr Specificity] -> Cxt -> Kind -> Kind
ForallT ((Name -> Name) -> TyVarBndr Specificity -> TyVarBndr Specificity
mapTyVarBndr Name -> Name
f (TyVarBndr Specificity -> TyVarBndr Specificity)
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr Specificity]
ts)
                                ((Name -> Name) -> Kind -> Kind
mapPred Name -> Name
f (Kind -> Kind) -> Cxt -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt
a) (Kind -> Kind
go Kind
b)
      AppT Kind
a Kind
b       -> Kind -> Kind -> Kind
AppT (Kind -> Kind
go Kind
a) (Kind -> Kind
go Kind
b)
      SigT Kind
t Kind
a       -> Kind -> Kind -> Kind
SigT (Kind -> Kind
go Kind
t) Kind
a
      VarT Name
n         -> Name -> Kind
VarT (Name -> Name
f Name
n)
      Kind
t              -> Kind
t

mapType :: (Type -> Type) -> Type -> Type
mapType :: (Kind -> Kind) -> Kind -> Kind
mapType Kind -> Kind
f = Kind -> Kind
go
  where
  go :: Kind -> Kind
go Kind
ty =
    case Kind
ty of
      ForallT [TyVarBndr Specificity]
v Cxt
c Kind
t -> Kind -> Kind
f ([TyVarBndr Specificity] -> Cxt -> Kind -> Kind
ForallT [TyVarBndr Specificity]
v Cxt
c (Kind -> Kind
go Kind
t))
      AppT Kind
a Kind
b      -> Kind -> Kind
f (Kind -> Kind -> Kind
AppT (Kind -> Kind
go Kind
a) (Kind -> Kind
go Kind
b))
      SigT Kind
t Kind
k      -> Kind -> Kind
f (Kind -> Kind -> Kind
SigT (Kind -> Kind
go Kind
t) Kind
k)
      Kind
_             -> Kind -> Kind
f Kind
ty

substitute :: Subst -> Type -> Type
substitute :: Subst -> Kind -> Kind
substitute Subst
env = (Kind -> Kind) -> Kind -> Kind
mapType Kind -> Kind
sub
  where sub :: Kind -> Kind
sub Kind
v = case Kind -> Subst -> Maybe Kind
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Kind
v Subst
env of
                  Maybe Kind
Nothing -> Kind
v
                  Just Kind
w  -> Kind
w

nameFromBinder :: TyVarBndr Specificity -> Name
#if MIN_VERSION_template_haskell(2,17,0)
nameFromBinder (PlainTV  n  _) = n
nameFromBinder (KindedTV n _ _) = n
#else
nameFromBinder :: TyVarBndr Specificity -> Name
nameFromBinder (PlainTV  Name
n  ) = Name
n
nameFromBinder (KindedTV Name
n Kind
_) = Name
n
#endif

mapPred :: (Name -> Name) -> Pred -> Pred
#if MIN_VERSION_template_haskell(2,10,0)
mapPred :: (Name -> Name) -> Kind -> Kind
mapPred = (Name -> Name) -> Kind -> Kind
mapTypeVariables
#else
mapPred f (ClassP n ts) = ClassP (f n) (mapTypeVariables f <$> ts)
mapPred f (EqualP t x ) = EqualP (mapTypeVariables f t) (mapTypeVariables f x)
#endif

mapTyVarBndr :: (Name -> Name) -> TyVarBndr Specificity
  -> TyVarBndr Specificity
#if MIN_VERSION_template_haskell(2,17,0)
mapTyVarBndr f (PlainTV  n flag) = PlainTV (f n) flag
mapTyVarBndr f (KindedTV n a flag) = KindedTV (f n) a flag
#else
mapTyVarBndr :: (Name -> Name) -> TyVarBndr Specificity -> TyVarBndr Specificity
mapTyVarBndr Name -> Name
f (PlainTV  Name
n) = Name -> TyVarBndr Specificity
PlainTV (Name -> Name
f Name
n)
mapTyVarBndr Name -> Name
f (KindedTV Name
n Kind
a) = Name -> Kind -> TyVarBndr Specificity
KindedTV (Name -> Name
f Name
n) Kind
a
#endif

-- Prettify a TH name.

pretty :: Name -> Name
pretty :: Name -> Name
pretty Name
tv = String -> Name
mkName ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_') (Name -> String
forall a. Show a => a -> String
show Name
tv))

-- 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 -> Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
dec
       Info
_ -> String -> Q Dec
forall a. String -> a
fclError String
"Info must be type declaration type."

-- Throw a fclabels specific error.

fclError :: String -> a
fclError :: String -> a
fclError String
err = String -> a
forall a. HasCallStack => String -> a
error (String
"Data.Label.Derive: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)

#if MIN_VERSION_template_haskell(2,10,0)
classP :: Name -> [Q Type] -> Q Pred
classP :: Name -> [TypeQ] -> TypeQ
classP Name
cla [TypeQ]
tys
  = do Cxt
tysl <- [TypeQ] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [TypeQ]
tys
       Kind -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return ((Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
cla) Cxt
tysl)
#endif

trd :: (a, b, c) -> c
trd :: (a, b, c) -> c
trd (a
_, b
_, c
x) = c
x