{- |
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,10,0)
import Language.Haskell.TH hiding (classP)
#else
import Language.Haskell.TH
#endif
import Prelude hiding ((.), id)

import qualified Data.Label.Mono     as Mono
import qualified Data.Label.Poly     as Poly

-------------------------------------------------------------------------------
-- 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]
vars    = [[TyVarBndr]] -> [TyVarBndr]
forall a. [a] -> a
head ([[TyVarBndr]] -> [TyVarBndr]) -> [[TyVarBndr]] -> [TyVarBndr]
forall a b. (a -> b) -> a -> b
$ (Label -> [TyVarBndr]) -> [Label] -> [[TyVarBndr]]
forall a b. (a -> b) -> [a] -> [b]
map (\(LabelExpr v :: [TyVarBndr]
v _ _ _) -> [TyVarBndr]
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] -> CxtQ -> TypeQ -> TypeQ
forallT [TyVarBndr]
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] -> CxtQ -> TypeQ -> TypeQ
forallT [TyVarBndr]
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]
vars mk :: Maybe Kind
mk cs :: [Con]
cs ns :: [DerivClause]
ns -> Cxt
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD    Cxt
ctx Name
nm [TyVarBndr]
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]
vars mk :: Maybe Kind
mk c :: Con
c  ns :: [DerivClause]
ns -> Cxt
-> Name -> [TyVarBndr] -> Maybe Kind -> Con -> [DerivClause] -> Dec
NewtypeD Cxt
ctx Name
nm [TyVarBndr]
vars Maybe Kind
mk (Con -> Con
con Con
c)      [DerivClause]
ns
#else
      DataD    ctx nm vars cs ns -> DataD    ctx nm vars (con <$> cs) ns
      NewtypeD ctx nm vars c  ns -> NewtypeD ctx nm vars (con c)      ns
#endif
      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]       -- The type variables requiring forall.
     CxtQ              -- The context.
     TypeQ             -- The type.
     ExpQ              -- The label body.
 | LabelExpr
     [TyVarBndr]       -- 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]          -- 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]
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] -> CxtQ -> TypeQ -> TypeQ
forallT [TyVarBndr]
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]
vars) =
          case Dec
dec of
#if MIN_VERSION_template_haskell(2,11,0)
            DataD    _ n :: Name
n vs :: [TyVarBndr]
vs _ cs :: [Con]
cs _ -> (Name
n, [Con]
cs,  [TyVarBndr]
vs)
            NewtypeD _ n :: Name
n vs :: [TyVarBndr]
vs _ c :: Con
c  _ -> (Name
n, [Con
c], [TyVarBndr]
vs)
#else
            DataD    _ n vs cs _ -> (n, cs,  vs)
            NewtypeD _ n vs c  _ -> (n, [c], vs)
#endif
            _ -> String -> (Name, [Con], [TyVarBndr])
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] -> [Con] -> [Field ([Context], Subst)]
groupFields String -> String
mk [TyVarBndr]
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]
-> [Con]
-> Field ([Context], Subst)
-> Q Label
generateLabel Bool
failing Bool
concrete Name
name [TyVarBndr]
vars [Con]
cons

groupFields :: (String -> String) -> [TyVarBndr] -> [Con] -> [Field ([Context], Subst)]
groupFields :: (String -> String)
-> [TyVarBndr] -> [Con] -> [Field ([Context], Subst)]
groupFields mk :: String -> String
mk vs :: [TyVarBndr]
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] -> Con -> [Field (Context, Subst)]
constructorFields [TyVarBndr]
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] -> Con -> [Field (Context, Subst)]
constructorFields :: [TyVarBndr] -> Con -> [Field (Context, Subst)]
constructorFields vs :: [TyVarBndr]
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]
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] -> Con -> [Field (Context, Subst)]
constructorFields [TyVarBndr]
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] -> Cxt -> Con -> Con
ForallC [TyVarBndr]
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] -> Kind -> Subst
mkSubst [TyVarBndr]
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] -> Kind -> Subst
mkSubst [TyVarBndr]
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] -> Type -> Subst
mkSubst :: [TyVarBndr] -> Kind -> Subst
mkSubst vars :: [TyVarBndr]
vars t :: Kind
t = [TyVarBndr] -> Kind -> Subst
go ([TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a]
reverse [TyVarBndr]
vars) Kind
t
  where
    go :: [TyVarBndr] -> Kind -> Subst
go [] _ = []
    go (v :: TyVarBndr
v:vs :: [TyVarBndr]
vs) (AppT t1 :: Kind
t1 t2 :: Kind
t2) = (TyVarBndr -> Kind
typeFromBinder TyVarBndr
v, Kind
t2) (Kind, Kind) -> Subst -> Subst
forall a. a -> [a] -> [a]
: [TyVarBndr] -> Kind -> Subst
go [TyVarBndr]
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]
-> [Con]
-> Field ([Context], Subst)
-> Q Label
generateLabel failing :: Bool
failing concrete :: Bool
concrete datatype :: Name
datatype dtVars :: [TyVarBndr]
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] -> Subst -> Q Typing
computeTypes Bool
forcedMono Kind
fieldtype Name
datatype [TyVarBndr]
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]
tvs <- [TyVarBndr] -> [TyVarBndr]
forall a. Eq a => [a] -> [a]
nub ([TyVarBndr] -> [TyVarBndr])
-> (Kind -> [TyVarBndr]) -> Kind -> [TyVarBndr]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Kind -> [TyVarBndr]
binderFromType (Kind -> [TyVarBndr]) -> TypeQ -> Q [TyVarBndr]
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] -> CxtQ -> TypeQ -> Q Exp -> Label
LabelExpr [TyVarBndr]
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] -> 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]
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] -> Subst -> Q Typing
computeTypes forcedMono :: Bool
forcedMono fieldtype :: Kind
fieldtype datatype :: Name
datatype dtVars_ :: [TyVarBndr]
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 -> Kind) -> TyVarBndr -> Kind
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TyVarBndr -> Kind
typeFromBinder (TyVarBndr -> Kind) -> [TyVarBndr] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr]
dtVars_
         dtBinders :: [TyVarBndr]
dtBinders = (Kind -> [TyVarBndr]) -> Cxt -> [TyVarBndr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Kind -> [TyVarBndr]
binderFromType Cxt
dtTypes
         varNames :: [Name]
varNames  = TyVarBndr -> Name
nameFromBinder (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr]
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]
pretties  = (Name -> Name) -> TyVarBndr -> TyVarBndr
mapTyVarBndr Name -> Name
pretty (TyVarBndr -> TyVarBndr) -> [TyVarBndr] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr]
dtBinders
         mono :: Bool
mono      = Bool
forcedMono Bool -> Bool -> Bool
|| Kind -> [TyVarBndr] -> Bool
isMonomorphic Kind
fieldtype [TyVarBndr]
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] -> 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] -> [TyVarBndr]
forall a. Eq a => [a] -> [a]
nub [TyVarBndr]
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] -> 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] -> [TyVarBndr]
forall a. Eq a => [a] -> [a]
nub ([TyVarBndr]
pretties [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ (TyVarBndr -> TyVarBndr) -> [TyVarBndr] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> Name) -> TyVarBndr -> TyVarBndr
mapTyVarBndr Name -> Name
pretty) (Name -> TyVarBndr
PlainTV (Name -> TyVarBndr)
-> ((Name, Name) -> Name) -> (Name, Name) -> TyVarBndr
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) -> [(Name, Name)] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Name)]
subs)))

isMonomorphic :: Type -> [TyVarBndr] -> Bool
isMonomorphic :: Kind -> [TyVarBndr] -> Bool
isMonomorphic field :: Kind
field vars :: [TyVarBndr]
vars =
  let fieldVars :: [Name]
fieldVars = Kind -> [Name]
typeVariables Kind
field
      varNames :: [Name]
varNames  = TyVarBndr -> Name
nameFromBinder (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr]
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 -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
nameFromBinder ([TyVarBndr] -> [Name]) -> (Kind -> [TyVarBndr]) -> 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]
binderFromType

typeFromBinder :: TyVarBndr -> Type
typeFromBinder :: TyVarBndr -> Kind
typeFromBinder (PlainTV  tv :: Name
tv      ) = Name -> Kind
VarT Name
tv
#if MIN_VERSION_template_haskell(2,8,0)
typeFromBinder (KindedTV tv :: Name
tv StarT) = Name -> Kind
VarT Name
tv
#else
typeFromBinder (KindedTV tv StarK) = VarT tv
#endif
typeFromBinder (KindedTV tv :: Name
tv kind :: Kind
kind ) = Kind -> Kind -> Kind
SigT (Name -> Kind
VarT Name
tv) Kind
kind

binderFromType :: Type -> [TyVarBndr]
binderFromType :: Kind -> [TyVarBndr]
binderFromType = Kind -> [TyVarBndr]
go
  where
  go :: Kind -> [TyVarBndr]
go ty :: Kind
ty =
    case Kind
ty of
      ForallT ts :: [TyVarBndr]
ts _ _ -> [TyVarBndr]
ts
      AppT a :: Kind
a b :: Kind
b       -> Kind -> [TyVarBndr]
go Kind
a [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ Kind -> [TyVarBndr]
go Kind
b
      SigT t :: Kind
t _       -> Kind -> [TyVarBndr]
go Kind
t
      VarT n :: Name
n         -> [Name -> TyVarBndr
PlainTV Name
n]
      _              -> []

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]
ts a :: Cxt
a b :: Kind
b -> [TyVarBndr] -> Cxt -> Kind -> Kind
ForallT ((Name -> Name) -> TyVarBndr -> TyVarBndr
mapTyVarBndr Name -> Name
f (TyVarBndr -> TyVarBndr) -> [TyVarBndr] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr]
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]
v c :: Cxt
c t :: Kind
t -> Kind -> Kind
f ([TyVarBndr] -> Cxt -> Kind -> Kind
ForallT [TyVarBndr]
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 -> Name
nameFromBinder :: TyVarBndr -> Name
nameFromBinder (PlainTV  n :: Name
n  ) = Name
n
nameFromBinder (KindedTV n :: Name
n _) = Name
n

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 -> TyVarBndr
mapTyVarBndr :: (Name -> Name) -> TyVarBndr -> TyVarBndr
mapTyVarBndr f :: Name -> Name
f (PlainTV  n :: Name
n  ) = Name -> TyVarBndr
PlainTV (Name -> Name
f Name
n)
mapTyVarBndr f :: Name -> Name
f (KindedTV n :: Name
n a :: Kind
a) = Name -> Kind -> TyVarBndr
KindedTV (Name -> Name
f Name
n) Kind
a

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