{- |
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 mk :: 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 sigs :: Bool
sigs concrete :: Bool
concrete failing :: Bool
failing name :: 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 _ _ _ b :: Q Exp
b) -> Q Exp
b) [Label]
labels
         types :: [TypeQ]
types   =        (Label -> TypeQ) -> [Label] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(LabelExpr _ _ t :: TypeQ
t _) -> 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 _ c :: CxtQ
c _ _) -> 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 v :: [TyVarBndr Specificity]
v _ _ _) -> [TyVarBndr Specificity]
v) [Label]
labels
     case [Q Exp]
bodies of
       [b :: 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
       _   -> 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 mk :: String -> String
mk sigs :: Bool
sigs concrete :: Bool
concrete failing :: Bool
failing inl :: Bool
inl name :: 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 field :: String
field =
  case String
field of
    '_' : c :: Char
c : rest :: String
rest -> Char -> Char
toLower Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest
    f :: Char
f : rest :: String
rest       -> 'l' Char -> String -> String
forall a. a -> [a] -> [a]
: Char -> Char
toUpper Char
f Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest
    n :: String
n              -> String -> String
forall a. String -> a
fclError ("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 decls :: 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
dec =
    case Dec
dec of
      DataD    {} -> [Dec
dec]
      NewtypeD {} -> [Dec
dec]
      _           -> []

  delabelize :: Dec -> Dec
  delabelize :: Dec -> Dec
delabelize dec :: Dec
dec =
    case Dec
dec of
#if MIN_VERSION_template_haskell(2,11,0)
      DataD    ctx :: Cxt
ctx nm :: Name
nm vars :: [TyVarBndr Specificity]
vars mk :: Maybe Kind
mk cs :: [Con]
cs ns :: [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 ctx :: Cxt
ctx nm :: Name
nm vars :: [TyVarBndr Specificity]
vars mk :: Maybe Kind
mk c :: Con
c  ns :: [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
      rest :: Dec
rest                       -> Dec
rest
    where con :: Con -> Con
con (RecC n :: Name
n vst :: [VarBangType]
vst) = Name -> [BangType] -> Con
NormalC Name
n ((VarBangType -> BangType) -> [VarBangType] -> [BangType]
forall a b. (a -> b) -> [a] -> [b]
map (\(_, s :: Bang
s, t :: Kind
t) -> (Bang
s, Kind
t)) [VarBangType]
vst)
#if MIN_VERSION_template_haskell(2,11,0)
          con (RecGadtC ns :: [Name]
ns vst :: [VarBangType]
vst ty :: Kind
ty) = [Name] -> [BangType] -> Kind -> Con
GadtC [Name]
ns ((VarBangType -> BangType) -> [VarBangType] -> [BangType]
forall a b. (a -> b) -> [a] -> [b]
map (\(_, s :: Bang
s, t :: Kind
t) -> (Bang
s, Kind
t)) [VarBangType]
vst) Kind
ty
#endif
          con c :: 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 mk :: String -> String
mk sigs :: Bool
sigs concrete :: Bool
concrete failing :: Bool
failing inl :: Bool
inl dec :: 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
$ \l :: Label
l ->
       case Label
l of
         LabelExpr {} -> [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
         LabelDecl n :: Name
n i :: Q Dec
i v :: [TyVarBndr Specificity]
v c :: CxtQ
c t :: TypeQ
t b :: 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 mk :: String -> String
mk concrete :: Bool
concrete failing :: Bool
failing dec :: Dec
dec =

 do -- Only process data and newtype declarations, filter out all
    -- constructors and the type variables.
    let (name :: Name
name, cons :: [Con]
cons, vars :: [TyVarBndr Specificity]
vars) =
          case Dec
dec of
#if MIN_VERSION_template_haskell(2,11,0)
            DataD    _ n :: Name
n vs :: [TyVarBndr Specificity]
vs _ cs :: [Con]
cs _ -> (Name
n, [Con]
cs,  [TyVarBndr Specificity]
vs)
            NewtypeD _ n :: Name
n vs :: [TyVarBndr Specificity]
vs _ c :: Con
c  _ -> (Name
n, [Con
c], [TyVarBndr Specificity]
vs)
#else
            DataD    _ n vs cs _ -> (n, cs,  vs)
            NewtypeD _ n vs c  _ -> (n, [c], vs)
#endif
            _ -> String -> (Name, [Con], [TyVarBndr Specificity])
forall a. String -> a
fclError "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 mk :: String -> String
mk vs :: [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 (\fs :: [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 n :: Maybe Name
n _ _ _) = Maybe Name
n
        eq :: Field c -> Field c -> Bool
eq f :: Field c
f g :: 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 f :: String -> String
f (Field n :: Maybe Name
n a :: Bool
a b :: Kind
b c :: 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 vs :: [TyVarBndr Specificity]
vs con :: Con
con =

  case Con
con of

    NormalC c :: Name
c fs :: [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 [0..] [BangType]
fs
      where one :: (Int, BangType) -> Field (Context, [a])
one (i :: Int
i, f :: BangType
f@(_, ty :: 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 (\x :: 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 c :: Name
c fs :: [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 [0..] [VarBangType]
fs
      where one :: (Int, VarBangType) -> Field (Context, [a])
one (i :: Int
i, f :: VarBangType
f@(n :: Name
n, _, ty :: 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 (\x :: 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 a :: BangType
a c :: Name
c b :: 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
<$> [(0, BangType
a), (1, BangType
b)]
      where one :: (Int, (a, Kind)) -> Field (Context, [a])
one (i :: Int
i, (_, ty :: 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 (\x :: 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 x :: [TyVarBndr Specificity]
x y :: Cxt
y v :: 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 EqualityT a :: Kind
a) b :: Kind
b <- Cxt
y ]
#else
      where eqs = [ (a, b) | EqualP a b <- y ]
#endif
            setEqs :: Field (Context, Subst) -> Field (Context, Subst)
setEqs (Field a :: Maybe Name
a b :: Bool
b c :: Kind
c d :: (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 a :: Int
a b :: Name
b c :: 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 cs :: [Name]
cs fs :: [BangType]
fs resTy :: Kind
resTy -> (Name -> [Field (Context, Subst)])
-> [Name] -> [Field (Context, Subst)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\c :: 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 [0..] [BangType]
fs) [Name]
cs
      where one :: Name -> (Int, BangType) -> Field (Context, Subst)
one c :: Name
c (i :: Int
i, f :: BangType
f@(_, ty :: 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 (\x :: 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 cs :: [Name]
cs fs :: [VarBangType]
fs resTy :: Kind
resTy -> (Name -> [Field (Context, Subst)])
-> [Name] -> [Field (Context, Subst)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\c :: 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 [0..] [VarBangType]
fs) [Name]
cs
      where one :: Name -> (Int, VarBangType) -> Field (Context, Subst)
one c :: Name
c (i :: Int
i, f :: VarBangType
f@(n :: Name
n, _, ty :: 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 (\x :: 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 vars :: [TyVarBndr Specificity]
vars t :: 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 [] _ = []
    go (v :: TyVarBndr Specificity
v:vs :: [TyVarBndr Specificity]
vs) (AppT t1 :: Kind
t1 t2 :: 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 _  _ = String -> Subst
forall a. String -> a
fclError "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 contexts :: [Context]
contexts allCons :: [Con]
allCons =
  case [Context]
contexts of
    (Context _ _ con :: Con
con) : _
       -> (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 a :: Con
a b :: 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
con =
          case Con
con of
            NormalC {}      -> []
            RecC    {}      -> []
            InfixC  {}      -> []
#if MIN_VERSION_template_haskell(2,11,0)
            ForallC _ _ ty :: 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 _ _ ty :: Kind
ty    -> Kind -> Cxt
conIndices Kind
ty
            RecGadtC _ _ ty :: Kind
ty -> Kind -> Cxt
conIndices Kind
ty
         where
           conIndices :: Kind -> Cxt
conIndices (AppT (ConT _) ty :: Kind
ty) = [Kind
ty]
           conIndices (AppT rest :: Kind
rest     ty :: Kind
ty) = Kind -> Cxt
conIndices Kind
rest Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ [Kind
ty]
           conIndices _                  = String -> Cxt
forall a. String -> a
fclError "Non-AppT in conIndices. Please report this as a bug for fclabels."
#endif

unifiable :: Type -> Type -> Bool
unifiable :: Kind -> Kind -> Bool
unifiable x :: Kind
x y :: Kind
y =
  case (Kind
x, Kind
y) of
    ( VarT _        ,      _        ) -> Bool
True
    ( _             , VarT _        ) -> Bool
True
    ( AppT a :: Kind
a b :: Kind
b      , AppT c :: Kind
c d :: Kind
d      ) -> Kind -> Kind -> Bool
unifiable Kind
a Kind
c Bool -> Bool -> Bool
&& Kind -> Kind -> Bool
unifiable Kind
b Kind
d
    ( SigT t :: Kind
t k :: Kind
k      , SigT s :: Kind
s j :: 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 _ _ t :: Kind
t , ForallT _ _ s :: Kind
s ) -> Kind -> Kind -> Bool
unifiable Kind
t Kind
s
    ( a :: Kind
a             , b :: 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 failing :: Bool
failing concrete :: Bool
concrete datatype :: Name
datatype dtVars :: [TyVarBndr Specificity]
dtVars allCons :: [Con]
allCons
              field :: Field ([Context], Subst)
field@(Field name :: Maybe Name
name forcedMono :: Bool
forcedMono fieldtype :: Kind
fieldtype (contexts :: [Context]
contexts, subst :: 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 mono :: Bool
mono tyI :: TypeQ
tyI tyO :: TypeQ
tyO _)
        <- 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 "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
         Nothing -> [TyVarBndr Specificity] -> CxtQ -> TypeQ -> Q Exp -> Label
LabelExpr [TyVarBndr Specificity]
tvs CxtQ
cont TypeQ
ty Q Exp
body
         Just n :: 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 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 g :: cat f o
g m :: 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 (\(n :: cat o i
n, (f :: f
f, o :: 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 failing :: Bool
failing total :: Bool
total (Field mn :: Maybe Name
mn _ _ (cons :: [Context]
cons, _)) =
  do let pt :: Name
pt = String -> Name
mkName "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 i :: Int
i _ c :: Con
c) = ((PatQ, Q Exp) -> MatchQ) -> [(PatQ, Q Exp)] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(pat :: PatQ
pat, var :: 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 i :: Int
i con :: Con
con =
    case Con
con of
      NormalC  c :: Name
c  fs :: [BangType]
fs   -> [[BangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [BangType]
fs Name
c]
      RecC     c :: Name
c  fs :: [VarBangType]
fs   -> [[VarBangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [VarBangType]
fs Name
c]
      InfixC   _  c :: Name
c  _ -> [(PatQ -> Name -> PatQ -> PatQ
infixP ([PatQ]
pats [PatQ] -> Int -> PatQ
forall a. [a] -> Int -> a
!! 0) Name
c ([PatQ]
pats [PatQ] -> Int -> PatQ
forall a. [a] -> Int -> a
!! 1), Q Exp
var)]
      ForallC  _  _  c :: Con
c -> Int -> Con -> [(PatQ, Q Exp)]
case1 Int
i Con
c
#if MIN_VERSION_template_haskell(2,11,0)
      GadtC    cs :: [Name]
cs fs :: [BangType]
fs _ -> (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 cs :: [Name]
cs fs :: [VarBangType]
fs _ -> (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 "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 fs :: t a
fs c :: 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 failing :: Bool
failing total :: Bool
total (Field mn :: Maybe Name
mn _ _ (cons :: [Context]
cons, _)) =
  do let pt :: Name
pt = String -> Name
mkName "f"
         md :: Name
md = String -> Name
mkName "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 i :: Int
i _ c :: Con
c) = ((PatQ, Q Exp) -> MatchQ) -> [(PatQ, Q Exp)] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(pat :: PatQ
pat, var :: 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 i :: Int
i con :: Con
con =
    case Con
con of
      NormalC  c :: Name
c  fs :: [BangType]
fs   -> [[BangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [BangType]
fs Name
c]
      RecC     c :: Name
c  fs :: [VarBangType]
fs   -> [[VarBangType] -> Name -> (PatQ, Q Exp)
forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
one [VarBangType]
fs Name
c]
      InfixC   _  c :: Name
c  _ -> [( PatQ -> Name -> PatQ -> PatQ
infixP ([PatQ]
pats [PatQ] -> Int -> PatQ
forall a. [a] -> Int -> a
!! 0) Name
c ([PatQ]
pats [PatQ] -> Int -> PatQ
forall a. [a] -> Int -> a
!! 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
!! 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
!! 1))
                          )
                         ]
      ForallC  _  _  c :: Con
c -> Int -> Con -> [(PatQ, Q Exp)]
case1 Int
i Con
c
#if MIN_VERSION_template_haskell(2,11,0)
      GadtC    cs :: [Name]
cs fs :: [BangType]
fs _ -> (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 cs :: [Name]
cs fs :: [VarBangType]
fs _ -> (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 "f" (String -> [String] -> [String]
forall a. Eq a => a -> [a] -> [a]
delete "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
+ 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 "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
+ 1) [Q Exp]
vars1
          apps :: Q Exp -> t (Q Exp) -> Q Exp
apps f :: Q Exp
f as :: 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 fs :: t a
fs c :: 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 ['a'..'z'] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Integer -> String) -> [Integer] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (('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) [0 :: Integer ..]

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

computeTypes :: Bool -> Type -> Name -> [TyVarBndr ()] -> Subst -> Q Typing
computeTypes :: Bool
-> Kind -> Name -> [TyVarBndr Specificity] -> Subst -> Q Typing
computeTypes forcedMono :: Bool
forcedMono fieldtype :: Kind
fieldtype datatype :: Name
datatype dtVars_ :: [TyVarBndr Specificity]
dtVars_ subst :: 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
<$> ['a'..'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) (\(a :: Name
a, b :: 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 (\a :: 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 field :: Kind
field vars :: [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  tv :: 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 tv :: Name
tv StarT) = Name -> Kind
VarT Name
tv
typeFromBinder (KindedTV tv :: Name
tv kind :: 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 ty :: Kind
ty =
    case Kind
ty of
      ForallT ts :: [TyVarBndr Specificity]
ts _ _ -> [TyVarBndr Specificity]
ts
      AppT a :: Kind
a b :: 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 t :: Kind
t _       -> Kind -> [TyVarBndr Specificity]
go Kind
t
#if MIN_VERSION_template_haskell(2,17,0)
      VarT n         -> [PlainTV n SpecifiedSpec]
#else
      VarT n :: Name
n         -> [Name -> TyVarBndr Specificity
PlainTV Name
n]
#endif
      _              -> []

mapTypeVariables :: (Name -> Name) -> Type -> Type
mapTypeVariables :: (Name -> Name) -> Kind -> Kind
mapTypeVariables f :: Name -> Name
f = Kind -> Kind
go
  where
  go :: Kind -> Kind
go ty :: Kind
ty =
    case Kind
ty of
      ForallT ts :: [TyVarBndr Specificity]
ts a :: Cxt
a b :: 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 a :: Kind
a b :: Kind
b       -> Kind -> Kind -> Kind
AppT (Kind -> Kind
go Kind
a) (Kind -> Kind
go Kind
b)
      SigT t :: Kind
t a :: Kind
a       -> Kind -> Kind -> Kind
SigT (Kind -> Kind
go Kind
t) Kind
a
      VarT n :: Name
n         -> Name -> Kind
VarT (Name -> Name
f Name
n)
      t :: Kind
t              -> Kind
t

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

substitute :: Subst -> Type -> Type
substitute :: Subst -> Kind -> Kind
substitute env :: Subst
env = (Kind -> Kind) -> Kind -> Kind
mapType Kind -> Kind
sub
  where sub :: Kind -> Kind
sub v :: Kind
v = case Kind -> Subst -> Maybe Kind
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Kind
v Subst
env of
                  Nothing -> Kind
v
                  Just w :: 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  n :: Name
n  ) = Name
n
nameFromBinder (KindedTV n :: Name
n _) = 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 f :: Name -> Name
f (PlainTV  n :: Name
n) = Name -> TyVarBndr Specificity
PlainTV (Name -> Name
f Name
n)
mapTyVarBndr f :: Name -> Name
f (KindedTV n :: Name
n a :: 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 tv :: 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
/= '_') (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
name =
  do Info
info <- Name -> Q Info
reify Name
name
     case Info
info of
       TyConI dec :: Dec
dec -> Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
dec
       _ -> String -> Q Dec
forall a. String -> a
fclError "Info must be type declaration type."

-- Throw a fclabels specific error.

fclError :: String -> a
fclError :: String -> a
fclError err :: String
err = String -> a
forall a. HasCallStack => String -> a
error ("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 cla :: Name
cla tys :: [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 (_, _, x :: c
x) = c
x