{-# LANGUAGE BangPatterns       #-}
{-# LANGUAGE CPP                #-}
{-# LANGUAGE MagicHash          #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE TemplateHaskell    #-}
{-|
Module:      TextShow.TH.Internal
Copyright:   (C) 2014-2017 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Stability:   Provisional
Portability: GHC

Functions to mechanically derive 'TextShow', 'TextShow1', or 'TextShow2' instances,
or to splice their functions directly into Haskell source code. You need to enable
the @TemplateHaskell@ language extension in order to use this module.

This implementation is loosely based off of the @Data.Aeson.TH@ module from the
@aeson@ library.
-}
module TextShow.TH.Internal (
      -- * 'deriveTextShow'
      -- $deriveTextShow
      deriveTextShow
      -- * 'deriveTextShow1'
      -- $deriveTextShow1
    , deriveTextShow1
      -- * 'deriveTextShow2'
      -- $deriveTextShow2
    , deriveTextShow2
      -- * @make-@ functions
      -- $make
    , makeShowt
    , makeShowtl
    , makeShowtPrec
    , makeShowtlPrec
    , makeShowtList
    , makeShowtlList
    , makeShowb
    , makeShowbPrec
    , makeShowbList
    , makePrintT
    , makePrintTL
    , makeHPrintT
    , makeHPrintTL
    , makeLiftShowbPrec
    , makeShowbPrec1
    , makeLiftShowbPrec2
    , makeShowbPrec2
    -- * 'Options'
    , Options(..)
    , defaultOptions
    , GenTextMethods(..)
    , deriveTextShowOptions
    , deriveTextShow1Options
    , deriveTextShow2Options
    ) where

import           Control.Monad (unless, when)
import qualified Control.Monad as Monad (fail)
import           Data.Foldable.Compat
import qualified Data.List.Compat as List
import           Data.List.NonEmpty.Compat (NonEmpty(..), (<|))
import qualified Data.Map as Map (fromList, keys, lookup, singleton)
import           Data.Map (Map)
import           Data.Maybe
import qualified Data.Set as Set
import           Data.Set (Set)
import qualified Data.Text    as TS
import qualified Data.Text.IO as TS (putStrLn, hPutStrLn)
import           Data.Text.Lazy (toStrict)
import qualified Data.Text.Lazy.Builder as TB
import           Data.Text.Lazy.Builder (Builder, toLazyText)
import qualified Data.Text.Lazy    as TL
import qualified Data.Text.Lazy.IO as TL (putStrLn, hPutStrLn)

import           GHC.Exts ( Char(..), Double(..), Float(..), Int(..), Word(..)
                          , Char#, Double#, Float#, Int#, Word#
#if MIN_VERSION_base(4,13,0)
                          , Int8#, Int16#, Word8#, Word16#
# if MIN_VERSION_base(4,16,0)
                          , Int32#, Word32#
#  if MIN_VERSION_base(4,19,0)
                          , Int64#, Word64#
#  else
                          , int8ToInt#, int16ToInt#, int32ToInt#
                          , intToInt8#, intToInt16#, intToInt32#
                          , word8ToWord#, word16ToWord#, word32ToWord#
                          , wordToWord8#, wordToWord16#, wordToWord32#
#  endif
# else
                          , extendInt8#, extendInt16#, extendWord8#, extendWord16#
                          , narrowInt8#, narrowInt16#, narrowWord8#, narrowWord16#
# endif
#endif
                          )
import           GHC.Show (appPrec, appPrec1)
#if MIN_VERSION_base(4,19,0)
import           GHC.Int (Int8(..), Int16(..), Int32(..), Int64(..))
import           GHC.Word (Word8(..), Word16(..), Word32(..), Word64(..))
#endif

import           Language.Haskell.TH.Datatype as Datatype
import           Language.Haskell.TH.Lib
import           Language.Haskell.TH.Ppr hiding (appPrec)
import           Language.Haskell.TH.Syntax

import           Prelude ()
import           Prelude.Compat

import           TextShow.Classes (TextShow(..), TextShow1(..), TextShow2(..),
                                   showbListWith,
                                   showbParen,  showbCommaSpace,  showbSpace,
                                   showtParen,  showtCommaSpace,  showtSpace,
                                   showtlParen, showtlCommaSpace, showtlSpace)
import           TextShow.Options (Options(..), GenTextMethods(..), defaultOptions)
import           TextShow.Utils (isInfixDataCon, isSymVar, isTupleString)

-------------------------------------------------------------------------------
-- User-facing API
-------------------------------------------------------------------------------

{- $deriveTextShow

'deriveTextShow' automatically generates a 'TextShow' instance declaration for a data
type, newtype, or data family instance. This emulates what would (hypothetically)
happen if you could attach a @deriving 'TextShow'@ clause to the end of a data
declaration.

Here are some examples of how to derive 'TextShow' for simple data types:

@
&#123;-&#35; LANGUAGE TemplateHaskell &#35;-&#125;
import TextShow.TH

data Letter = A | B | C
$('deriveTextShow' ''Letter) -- instance TextShow Letter where ...

newtype Box a = Box a
$('deriveTextShow' ''Box) -- instance TextShow a => TextShow (Box a) where ...
@

'deriveTextShow' can also be used to derive 'TextShow' instances for data family
instances (which requires the @-XTypeFamilies@ extension). To do so, pass the name of
a data or newtype instance constructor (NOT a data family name!) to 'deriveTextShow'.
Note that the generated code may require the @-XFlexibleInstances@ extension.
Some examples:

@
&#123;-&#35; LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies &#35;-&#125;
import TextShow.TH (deriveTextShow)

class AssocClass a where
    data AssocData a
instance AssocClass Int where
    data AssocData Int = AssocDataInt1 Int | AssocDataInt2 Int Int
$('deriveTextShow' 'AssocDataInt1) -- instance TextShow (AssocData Int) where ...
-- Alternatively, one could use $(deriveTextShow 'AssocDataInt2)

data family DataFam a b
newtype instance DataFam () b = DataFamB b
$('deriveTextShow' 'DataFamB) -- instance TextShow b => TextShow (DataFam () b)
@

Note that at the moment, there are some limitations:

* The 'Name' argument to 'deriveTextShow' must not be a type synonym.

* 'deriveTextShow' makes the assumption that all type variables of kind @*@ require a
  'TextShow' constraint when creating the type context. For example, if you have @data
  Phantom a = Phantom@, then @('deriveTextShow' ''Phantom)@ will generate @instance
  'TextShow' a => 'TextShow' (Phantom a) where ...@, even though @'TextShow' a@ is
  not required. If you want a proper 'TextShow' instance for @Phantom@, you will need
  to use 'makeShowbPrec' (see the documentation of the @make@ functions for more
  information).

* 'deriveTextShow' lacks the ability to properly detect data types with higher-kinded
   type parameters (e.g., @data HK f a = HK (f a)@) or with kinds other than @*@
   (e.g., @data List a (empty :: Bool)@). If you wish to derive 'TextShow'
   instances for these data types, you will need to use 'makeShowbPrec'.

* Some data constructors have arguments whose 'TextShow' instance depends on a
  typeclass besides 'TextShow'. For example, consider @newtype MyFixed a = MyFixed
  (Fixed a)@. @'Fixed' a@ is a 'TextShow' instance only if @a@ is an instance of both
  @HasResolution@ and 'TextShow'. Unfortunately, 'deriveTextShow' cannot infer that
  'a' must be an instance of 'HasResolution', so it cannot create a 'TextShow'
  instance for @MyFixed@. However, you can use 'makeShowbPrec' to get around this.

-}

-- | Generates a 'TextShow' instance declaration for the given data type or data
-- family instance.
--
-- /Since: 2/
deriveTextShow :: Name -> Q [Dec]
deriveTextShow :: Name -> Q [Dec]
deriveTextShow = Options -> Name -> Q [Dec]
deriveTextShowOptions Options
defaultOptions

-- | Like 'deriveTextShow', but takes an 'Options' argument.
--
-- /Since: 3.4/
deriveTextShowOptions :: Options -> Name -> Q [Dec]
deriveTextShowOptions :: Options -> Name -> Q [Dec]
deriveTextShowOptions = TextShowClass -> Options -> Name -> Q [Dec]
deriveTextShowClass TextShowClass
TextShow

{- $deriveTextShow1

'deriveTextShow1' automatically generates a 'Show1' instance declaration for a data
type, newtype, or data family instance that has at least one type variable.
This emulates what would (hypothetically) happen if you could attach a @deriving
'TextShow1'@ clause to the end of a data declaration. Examples:

@
&#123;-&#35; LANGUAGE TemplateHaskell &#35;-&#125;
import TextShow.TH

data Stream a = Stream a (Stream a)
$('deriveTextShow1' ''Stream) -- instance TextShow1 TextStream where ...

newtype WrappedFunctor f a = WrapFunctor (f a)
$('deriveTextShow1' ''WrappedFunctor) -- instance TextShow1 f => TextShow1 (WrappedFunctor f) where ...
@

The same restrictions that apply to 'deriveTextShow' also apply to 'deriveTextShow1',
with some caveats:

* With 'deriveTextShow1', the last type variable must be of kind @*@. For other ones,
  type variables of kind @*@ are assumed to require a 'TextShow' context, and type
  variables of kind @* -> *@ are assumed to require a 'TextShow1' context. For more
  complicated scenarios, use 'makeLiftShowbPrec'.

* If using @-XDatatypeContexts@, a datatype constraint cannot mention the last type
  variable. For example, @data Ord a => Illegal a = Illegal a@ cannot have a derived
  'TextShow1' instance.

* If the last type variable is used within a data field of a constructor, it must only
  be used in the last argument of the data type constructor. For example, @data Legal a
  = Legal (Either Int a)@ can have a derived 'TextShow1' instance, but @data Illegal a
  = Illegal (Either a a)@ cannot.

* Data family instances must be able to eta-reduce the last type variable. In other
  words, if you have a instance of the form:

  @
  data family Family a1 ... an t
  data instance Family e1 ... e2 v = ...
  @

  Then the following conditions must hold:

  1. @v@ must be a type variable.
  2. @v@ must not be mentioned in any of @e1@, ..., @e2@.

-}

-- | Generates a 'TextShow1' instance declaration for the given data type or data
-- family instance.
--
-- /Since: 2/
deriveTextShow1 :: Name -> Q [Dec]
deriveTextShow1 :: Name -> Q [Dec]
deriveTextShow1 = Options -> Name -> Q [Dec]
deriveTextShow1Options Options
defaultOptions

-- | Like 'deriveTextShow1', but takes an 'Options' argument.
--
-- /Since: 3.4/
deriveTextShow1Options :: Options -> Name -> Q [Dec]
deriveTextShow1Options :: Options -> Name -> Q [Dec]
deriveTextShow1Options = TextShowClass -> Options -> Name -> Q [Dec]
deriveTextShowClass TextShowClass
TextShow1

{- $deriveTextShow2

'deriveTextShow2' automatically generates a 'TextShow2' instance declaration for a data
type, newtype, or data family instance that has at least two type variables.
This emulates what would (hypothetically) happen if you could attach a @deriving
'TextShow2'@ clause to the end of a data declaration. Examples:

@
&#123;-&#35; LANGUAGE TemplateHaskell &#35;-&#125;
import TextShow.TH

data OneOrNone a b = OneL a | OneR b | None
$('deriveTextShow2' ''OneOrNone) -- instance TextShow2 OneOrNone where ...

newtype WrappedBifunctor f a b = WrapBifunctor (f a b)
$('deriveTextShow2' ''WrappedBifunctor) -- instance TextShow2 f => TextShow2 (WrappedBifunctor f) where ...
@

The same restrictions that apply to 'deriveTextShow' and 'deriveTextShow1' also apply
to 'deriveTextShow2', with some caveats:

* With 'deriveTextShow2', the last type variables must both be of kind @*@. For other
  ones, type variables of kind @*@ are assumed to require a 'TextShow' constraint, type
  variables of kind @* -> *@ are assumed to require a 'TextShow1' constraint, and type
  variables of kind @* -> * -> *@ are assumed to require a 'TextShow2' constraint. For
  more complicated scenarios, use 'makeLiftShowbPrec2'.

* If using @-XDatatypeContexts@, a datatype constraint cannot mention either of the last
  two type variables. For example, @data Ord a => Illegal a b = Illegal a b@ cannot
  have a derived 'TextShow2' instance.

* If either of the last two type variables is used within a data field of a constructor,
  it must only be used in the last two arguments of the data type constructor. For
  example, @data Legal a b = Legal (Int, Int, a, b)@ can have a derived 'TextShow2'
  instance, but @data Illegal a b = Illegal (a, b, a, b)@ cannot.

* Data family instances must be able to eta-reduce the last two type variables. In other
  words, if you have a instance of the form:

  @
  data family Family a1 ... an t1 t2
  data instance Family e1 ... e2 v1 v2 = ...
  @

  Then the following conditions must hold:

  1. @v1@ and @v2@ must be distinct type variables.
  2. Neither @v1@ not @v2@ must be mentioned in any of @e1@, ..., @e2@.

-}

-- | Generates a 'TextShow2' instance declaration for the given data type or data
-- family instance.
--
-- /Since: 2/
deriveTextShow2 :: Name -> Q [Dec]
deriveTextShow2 :: Name -> Q [Dec]
deriveTextShow2 = Options -> Name -> Q [Dec]
deriveTextShow2Options Options
defaultOptions

-- | Like 'deriveTextShow2', but takes an 'Options' argument.
--
-- /Since: 3.4/
deriveTextShow2Options :: Options -> Name -> Q [Dec]
deriveTextShow2Options :: Options -> Name -> Q [Dec]
deriveTextShow2Options = TextShowClass -> Options -> Name -> Q [Dec]
deriveTextShowClass TextShowClass
TextShow2

{- $make

There may be scenarios in which you want to show an arbitrary data type or data
family instance without having to make the type an instance of 'TextShow'. For these
cases, this modules provides several functions (all prefixed with @make@-) that
splice the appropriate lambda expression into your source code. Example:

This is particularly useful for creating instances for sophisticated data types. For
example, 'deriveTextShow' cannot infer the correct type context for
@newtype HigherKinded f a = HigherKinded (f a)@, since @f@ is of kind @* -> *@.
However, it is still possible to derive a 'TextShow' instance for @HigherKinded@
without too much trouble using 'makeShowbPrec':

@
&#123;-&#35; LANGUAGE FlexibleContexts, TemplateHaskell &#35;-&#125;
import TextShow
import TextShow.TH

instance TextShow (f a) => TextShow (HigherKinded f a) where
    showbPrec = $(makeShowbPrec ''HigherKinded)
@

-}

-- | Generates a lambda expression which behaves like 'showt' (without requiring a
-- 'TextShow' instance).
--
-- /Since: 2/
makeShowt :: Name -> Q Exp
makeShowt :: Name -> Q Exp
makeShowt Name
name = Name -> Q Exp
makeShowtPrec Name
name Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Q Exp
integerE Int
0

-- | Generates a lambda expression which behaves like 'showtl' (without requiring a
-- 'TextShow' instance).
--
-- /Since: 2/
makeShowtl :: Name -> Q Exp
makeShowtl :: Name -> Q Exp
makeShowtl Name
name = Name -> Q Exp
makeShowtlPrec Name
name Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Q Exp
integerE Int
0

-- | Generates a lambda expression which behaves like 'showtPrec' (without requiring a
-- 'TextShow' instance).
--
-- /Since: 2/
makeShowtPrec :: Name -> Q Exp
makeShowtPrec :: Name -> Q Exp
makeShowtPrec = TextShowClass -> TextShowFun -> Options -> Name -> Q Exp
makeShowbPrecClass TextShowClass
TextShow TextShowFun
ShowtPrec Options
defaultOptions

-- | Generates a lambda expression which behaves like 'showtlPrec' (without
-- requiring a 'TextShow' instance).
--
-- /Since: 2/
makeShowtlPrec :: Name -> Q Exp
makeShowtlPrec :: Name -> Q Exp
makeShowtlPrec = TextShowClass -> TextShowFun -> Options -> Name -> Q Exp
makeShowbPrecClass TextShowClass
TextShow TextShowFun
ShowtlPrec Options
defaultOptions

-- | Generates a lambda expression which behaves like 'showtList' (without requiring a
-- 'TextShow' instance).
--
-- /Since: 2/
makeShowtList :: Name -> Q Exp
makeShowtList :: Name -> Q Exp
makeShowtList Name
name = [| toStrict . $(Name -> Q Exp
makeShowtlList Name
name) |]

-- | Generates a lambda expression which behaves like 'showtlList' (without
-- requiring a 'TextShow' instance).
--
-- /Since: 2/
makeShowtlList :: Name -> Q Exp
makeShowtlList :: Name -> Q Exp
makeShowtlList Name
name = [| toLazyText . $(Name -> Q Exp
makeShowbList Name
name) |]

-- | Generates a lambda expression which behaves like 'showb' (without requiring a
-- 'TextShow' instance).
--
-- /Since: 2/
makeShowb :: Name -> Q Exp
makeShowb :: Name -> Q Exp
makeShowb Name
name = Name -> Q Exp
makeShowbPrec Name
name Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Q Exp
integerE Int
0

-- | Generates a lambda expression which behaves like 'showbPrec' (without requiring a
-- 'TextShow' instance).
--
-- /Since: 2/
makeShowbPrec :: Name -> Q Exp
makeShowbPrec :: Name -> Q Exp
makeShowbPrec = TextShowClass -> TextShowFun -> Options -> Name -> Q Exp
makeShowbPrecClass TextShowClass
TextShow TextShowFun
ShowbPrec Options
defaultOptions

-- | Generates a lambda expression which behaves like 'liftShowbPrec' (without
-- requiring a 'TextShow1' instance).
--
-- /Since: 3/
makeLiftShowbPrec :: Name -> Q Exp
makeLiftShowbPrec :: Name -> Q Exp
makeLiftShowbPrec = TextShowClass -> TextShowFun -> Options -> Name -> Q Exp
makeShowbPrecClass TextShowClass
TextShow1 TextShowFun
ShowbPrec Options
defaultOptions

-- | Generates a lambda expression which behaves like 'showbPrec1' (without
-- requiring a 'TextShow1' instance).
--
-- /Since: 2/
makeShowbPrec1 :: Name -> Q Exp
makeShowbPrec1 :: Name -> Q Exp
makeShowbPrec1 Name
name = [| $(Name -> Q Exp
makeLiftShowbPrec Name
name) showbPrec showbList |]

-- | Generates a lambda expression which behaves like 'liftShowbPrec2' (without
-- requiring a 'TextShow2' instance).
--
-- /Since: 3/
makeLiftShowbPrec2 :: Name -> Q Exp
makeLiftShowbPrec2 :: Name -> Q Exp
makeLiftShowbPrec2 = TextShowClass -> TextShowFun -> Options -> Name -> Q Exp
makeShowbPrecClass TextShowClass
TextShow2 TextShowFun
ShowbPrec Options
defaultOptions

-- | Generates a lambda expression which behaves like 'showbPrec2' (without
-- requiring a 'TextShow2' instance).
--
-- /Since: 2/
makeShowbPrec2 :: Name -> Q Exp
makeShowbPrec2 :: Name -> Q Exp
makeShowbPrec2 Name
name = [| $(Name -> Q Exp
makeLiftShowbPrec2 Name
name) showbPrec showbList showbPrec showbList |]

-- | Generates a lambda expression which behaves like 'showbList' (without requiring a
-- 'TextShow' instance).
--
-- /Since: 2/
makeShowbList :: Name -> Q Exp
makeShowbList :: Name -> Q Exp
makeShowbList Name
name = [| showbListWith $(Name -> Q Exp
makeShowb Name
name) |]

-- | Generates a lambda expression which behaves like 'printT' (without requiring a
-- 'TextShow' instance).
--
-- /Since: 2/
makePrintT :: Name -> Q Exp
makePrintT :: Name -> Q Exp
makePrintT Name
name = [| TS.putStrLn . $(Name -> Q Exp
makeShowt Name
name) |]

-- | Generates a lambda expression which behaves like 'printTL' (without requiring a
-- 'TextShow' instance).
--
-- /Since: 2/
makePrintTL :: Name -> Q Exp
makePrintTL :: Name -> Q Exp
makePrintTL Name
name = [| TL.putStrLn . $(Name -> Q Exp
makeShowtl Name
name) |]

-- | Generates a lambda expression which behaves like 'hPrintT' (without requiring a
-- 'TextShow' instance).
--
-- /Since: 2/
makeHPrintT :: Name -> Q Exp
makeHPrintT :: Name -> Q Exp
makeHPrintT Name
name = [| \h -> TS.hPutStrLn h . $(Name -> Q Exp
makeShowt Name
name) |]

-- | Generates a lambda expression which behaves like 'hPrintTL' (without
-- requiring a 'TextShow' instance).
--
-- /Since: 2/
makeHPrintTL :: Name -> Q Exp
makeHPrintTL :: Name -> Q Exp
makeHPrintTL Name
name = [| \h -> TL.hPutStrLn h . $(Name -> Q Exp
makeShowtl Name
name) |]

-------------------------------------------------------------------------------
-- Code generation
-------------------------------------------------------------------------------

-- | Derive a TextShow(1)(2) instance declaration (depending on the TextShowClass
-- argument's value).
deriveTextShowClass :: TextShowClass -> Options -> Name -> Q [Dec]
deriveTextShowClass :: TextShowClass -> Options -> Name -> Q [Dec]
deriveTextShowClass TextShowClass
tsClass Options
opts Name
name = do
  DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  case DatatypeInfo
info of
    DatatypeInfo { datatypeContext :: DatatypeInfo -> [Type]
datatypeContext   = [Type]
ctxt
                 , datatypeName :: DatatypeInfo -> Name
datatypeName      = Name
parentName
                 , datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes = [Type]
instTys
                 , datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant   = DatatypeVariant
variant
                 , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons
                 } -> do
      ([Type]
instanceCxt, Type
instanceType)
        <- TextShowClass
-> Name -> [Type] -> [Type] -> DatatypeVariant -> Q ([Type], Type)
buildTypeInstance TextShowClass
tsClass Name
parentName [Type]
ctxt [Type]
instTys DatatypeVariant
variant
      (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
instanceCxt)
                          (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
                          (TextShowClass -> Options -> [Type] -> [ConstructorInfo] -> [Q Dec]
showbPrecDecs TextShowClass
tsClass Options
opts [Type]
instTys [ConstructorInfo]
cons)

-- | Generates a declaration defining the primary function corresponding to a
-- particular class (showbPrec for TextShow, liftShowbPrec for TextShow1, and
-- liftShowbPrec2 for TextShow2).
showbPrecDecs :: TextShowClass -> Options -> [Type] -> [ConstructorInfo] -> [Q Dec]
showbPrecDecs :: TextShowClass -> Options -> [Type] -> [ConstructorInfo] -> [Q Dec]
showbPrecDecs TextShowClass
tsClass Options
opts [Type]
instTys [ConstructorInfo]
cons =
    [TextShowFun -> Name -> Q Dec
genMethod TextShowFun
ShowbPrec (TextShowClass -> Name
showbPrecName TextShowClass
tsClass)]
    [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++ if TextShowClass
tsClass TextShowClass -> TextShowClass -> Bool
forall a. Eq a => a -> a -> Bool
== TextShowClass
TextShow Bool -> Bool -> Bool
&& Bool
shouldGenTextMethods
          then [TextShowFun -> Name -> Q Dec
genMethod TextShowFun
ShowtPrec 'showtPrec, TextShowFun -> Name -> Q Dec
genMethod TextShowFun
ShowtlPrec 'showtlPrec]
          else []
  where
    shouldGenTextMethods :: Bool
    shouldGenTextMethods :: Bool
shouldGenTextMethods = case Options -> GenTextMethods
genTextMethods Options
opts of
      GenTextMethods
AlwaysTextMethods    -> Bool
True
      GenTextMethods
SometimesTextMethods -> (ConstructorInfo -> Bool) -> [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConstructorInfo -> Bool
isNullaryCon [ConstructorInfo]
cons
      GenTextMethods
NeverTextMethods     -> Bool
False

    genMethod :: TextShowFun -> Name -> Q Dec
    genMethod :: TextShowFun -> Name -> Q Dec
genMethod TextShowFun
method Name
methodName
      = Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
methodName
             [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
                      (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ TextShowClass
-> TextShowFun -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
makeTextShowForCons TextShowClass
tsClass TextShowFun
method Options
opts [Type]
instTys [ConstructorInfo]
cons)
                      []
             ]


-- | Generates a lambda expression which behaves like showbPrec (for TextShow),
-- liftShowbPrec (for TextShow1), or liftShowbPrec2 (for TextShow2).
makeShowbPrecClass :: TextShowClass -> TextShowFun -> Options -> Name -> Q Exp
makeShowbPrecClass :: TextShowClass -> TextShowFun -> Options -> Name -> Q Exp
makeShowbPrecClass TextShowClass
tsClass TextShowFun
tsFun Options
opts Name
name = do
  DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  case DatatypeInfo
info of
    DatatypeInfo { datatypeContext :: DatatypeInfo -> [Type]
datatypeContext   = [Type]
ctxt
                 , datatypeName :: DatatypeInfo -> Name
datatypeName      = Name
parentName
                 , datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes = [Type]
instTys
                 , datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant   = DatatypeVariant
variant
                 , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons
                 } ->
      -- We force buildTypeInstance here since it performs some checks for whether
      -- or not the provided datatype can actually have showbPrec/liftShowbPrec/etc.
      -- implemented for it, and produces errors if it can't.
      TextShowClass
-> Name -> [Type] -> [Type] -> DatatypeVariant -> Q ([Type], Type)
buildTypeInstance TextShowClass
tsClass Name
parentName [Type]
ctxt [Type]
instTys DatatypeVariant
variant
        Q ([Type], Type) -> Q Exp -> Q Exp
forall a b. Q a -> Q b -> Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextShowClass
-> TextShowFun -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
makeTextShowForCons TextShowClass
tsClass TextShowFun
tsFun Options
opts [Type]
instTys [ConstructorInfo]
cons

-- | Generates a lambda expression for showbPrec/liftShowbPrec/etc. for the
-- given constructors. All constructors must be from the same type.
makeTextShowForCons :: TextShowClass -> TextShowFun -> Options -> [Type] -> [ConstructorInfo]
                    -> Q Exp
makeTextShowForCons :: TextShowClass
-> TextShowFun -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
makeTextShowForCons TextShowClass
tsClass TextShowFun
tsFun Options
opts [Type]
instTys [ConstructorInfo]
cons = do
    Name
p       <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"p"
    Name
value   <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"value"
    [Name]
sps     <- String -> Int -> Q [Name]
newNameList String
"sp" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ TextShowClass -> Int
forall a. Enum a => a -> Int
fromEnum TextShowClass
tsClass
    [Name]
sls     <- String -> Int -> Q [Name]
newNameList String
"sl" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ TextShowClass -> Int
forall a. Enum a => a -> Int
fromEnum TextShowClass
tsClass
    let spls :: [(Name, Name)]
spls       = [Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
sps [Name]
sls
        spsAndSls :: [Name]
spsAndSls  = [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
interleave [Name]
sps [Name]
sls
        lastTyVars :: [Name]
lastTyVars = (Type -> Name) -> [Type] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName ([Type] -> [Name]) -> [Type] -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
instTys Int -> Int -> Int
forall a. Num a => a -> a -> a
- TextShowClass -> Int
forall a. Enum a => a -> Int
fromEnum TextShowClass
tsClass) [Type]
instTys
        splMap :: Map Name (Name, Name)
splMap     = [(Name, (Name, Name))] -> Map Name (Name, Name)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, (Name, Name))] -> Map Name (Name, Name))
-> [(Name, (Name, Name))] -> Map Name (Name, Name)
forall a b. (a -> b) -> a -> b
$ [Name] -> [(Name, Name)] -> [(Name, (Name, Name))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
lastTyVars [(Name, Name)]
spls

        makeFun :: Q Exp
makeFun
          | [ConstructorInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons Bool -> Bool -> Bool
&& Options -> Bool
emptyCaseBehavior Options
opts
          = Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value) []

          | [ConstructorInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons
          = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'seq) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
            Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'error)
                 (String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Void " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase (TextShowClass -> TextShowFun -> Name
showPrecName TextShowClass
tsClass TextShowFun
tsFun))

          | Bool
otherwise
          = Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value)
                  ((ConstructorInfo -> Q Match) -> [ConstructorInfo] -> [Q Match]
forall a b. (a -> b) -> [a] -> [b]
map (Name
-> TextShowClass
-> TextShowFun
-> Map Name (Name, Name)
-> ConstructorInfo
-> Q Match
makeTextShowForCon Name
p TextShowClass
tsClass TextShowFun
tsFun Map Name (Name, Name)
splMap) [ConstructorInfo]
cons)

    [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP ([Name] -> [Q Pat]) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> a -> b
$ [Name]
spsAndSls [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
p, Name
value])
        (Q Exp -> Q Exp) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
        ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ TextShowClass -> TextShowFun -> Name
showPrecConstName TextShowClass
tsClass TextShowFun
tsFun
          , Q Exp
makeFun
          ] [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
spsAndSls
            [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ [Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value]

-- | Generates a lambda expression for showbPrec/liftShowbPrec/etc. for a
-- single constructor.
makeTextShowForCon :: Name
                   -> TextShowClass
                   -> TextShowFun
                   -> TyVarMap
                   -> ConstructorInfo
                   -> Q Match
makeTextShowForCon :: Name
-> TextShowClass
-> TextShowFun
-> Map Name (Name, Name)
-> ConstructorInfo
-> Q Match
makeTextShowForCon Name
_ TextShowClass
_ TextShowFun
tsFun Map Name (Name, Name)
_
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName, constructorFields :: ConstructorInfo -> [Type]
constructorFields = [] }) =
    Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
      (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName [])
      (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB  (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
fromStringName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> String -> String
parenInfixConName Name
conName String
""))
      []
makeTextShowForCon Name
p TextShowClass
tsClass TextShowFun
tsFun Map Name (Name, Name)
tvMap
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                   , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor
                   , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type
argTy] }) = do
    Type
argTy' <- Type -> Q Type
resolveTypeSynonyms Type
argTy
    Name
arg <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"arg"

    let showArg :: Q Exp
showArg  = Int
-> TextShowClass
-> TextShowFun
-> Name
-> Map Name (Name, Name)
-> Type
-> Name
-> Q Exp
makeTextShowForArg Int
appPrec1 TextShowClass
tsClass TextShowFun
tsFun Name
conName Map Name (Name, Name)
tvMap Type
argTy' Name
arg
        namedArg :: Q Exp
namedArg = Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
fromStringName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> String -> String
parenInfixConName Name
conName String
" "))
                            [| (<>) |]
                            Q Exp
showArg

    Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
      (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
arg])
      (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
showParenName TextShowFun
tsFun)
                  Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p) [| (>) |] (Int -> Q Exp
integerE Int
appPrec)
                  Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
namedArg)
      []
makeTextShowForCon Name
p TextShowClass
tsClass TextShowFun
tsFun Map Name (Name, Name)
tvMap
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                   , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor
                   , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
argTys }) = do
    [Type]
argTys' <- (Type -> Q Type) -> [Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q Type
resolveTypeSynonyms [Type]
argTys
    [Name]
args <- String -> Int -> Q [Name]
newNameList String
"arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
argTys'

    if Name -> Bool
isNonUnitTuple Name
conName
       then do
         let showArgs :: [Q Exp]
showArgs       = (Type -> Name -> Q Exp) -> [Type] -> [Name] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int
-> TextShowClass
-> TextShowFun
-> Name
-> Map Name (Name, Name)
-> Type
-> Name
-> Q Exp
makeTextShowForArg Int
0 TextShowClass
tsClass TextShowFun
tsFun Name
conName Map Name (Name, Name)
tvMap) [Type]
argTys' [Name]
args
             parenCommaArgs :: [Q Exp]
parenCommaArgs = (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
singletonName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
'(')
                              Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
List.intersperse (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
singletonName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
',') [Q Exp]
showArgs
             mappendArgs :: Q Exp
mappendArgs    = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' (Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
`infixApp` [| (<>) |])
                                     (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
singletonName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
')')
                                     [Q Exp]
parenCommaArgs

         Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args)
               (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
mappendArgs)
               []
       else do
         let showArgs :: [Q Exp]
showArgs    = (Type -> Name -> Q Exp) -> [Type] -> [Name] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int
-> TextShowClass
-> TextShowFun
-> Name
-> Map Name (Name, Name)
-> Type
-> Name
-> Q Exp
makeTextShowForArg Int
appPrec1 TextShowClass
tsClass TextShowFun
tsFun Name
conName Map Name (Name, Name)
tvMap) [Type]
argTys' [Name]
args
             mappendArgs :: Q Exp
mappendArgs = (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Q Exp
v Q Exp
q -> Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
v
                                                    [| (<>) |]
                                                    (Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ TextShowFun -> Name
showSpaceName TextShowFun
tsFun)
                                                              [| (<>) |]
                                                              Q Exp
q)) [Q Exp]
showArgs
             namedArgs :: Q Exp
namedArgs   = Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
fromStringName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> String -> String
parenInfixConName Name
conName String
" "))
                                    [| (<>) |]
                                    Q Exp
mappendArgs

         Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args)
               (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
showParenName TextShowFun
tsFun)
                            Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p) [| (>) |] (Int -> Q Exp
integerE Int
appPrec)
                            Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
namedArgs)
               []
makeTextShowForCon Name
p TextShowClass
tsClass TextShowFun
tsFun Map Name (Name, Name)
tvMap
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                   , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = RecordConstructor [Name]
argNames
                   , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
argTys }) = do
    [Type]
argTys' <- (Type -> Q Type) -> [Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q Type
resolveTypeSynonyms [Type]
argTys
    [Name]
args <- String -> Int -> Q [Name]
newNameList String
"arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
argTys'

    let showArgs :: [Q Exp]
showArgs       = ((Name, Type, Name) -> [Q Exp]) -> [(Name, Type, Name)] -> [Q Exp]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Name
argName, Type
argTy, Name
arg)
                                      -> let argNameBase :: String
argNameBase = Name -> String
nameBase Name
argName
                                             infixRec :: String
infixRec    = Bool -> (String -> String) -> String -> String
showParen (String -> Bool
isSymVar String
argNameBase)
                                                                     (String -> String -> String
showString String
argNameBase) String
""
                                         in [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
fromStringName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String
infixRec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = ")
                                            , Int
-> TextShowClass
-> TextShowFun
-> Name
-> Map Name (Name, Name)
-> Type
-> Name
-> Q Exp
makeTextShowForArg Int
0 TextShowClass
tsClass TextShowFun
tsFun Name
conName Map Name (Name, Name)
tvMap Type
argTy Name
arg
                                            , Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
showCommaSpaceName TextShowFun
tsFun)
                                            ]
                                   )
                                   ([Name] -> [Type] -> [Name] -> [(Name, Type, Name)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
argNames [Type]
argTys' [Name]
args)
        braceCommaArgs :: [Q Exp]
braceCommaArgs = (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
singletonName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
'{') Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: Int -> [Q Exp] -> [Q Exp]
forall a. Int -> [a] -> [a]
take ([Q Exp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Exp]
showArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Q Exp]
showArgs
        mappendArgs :: Q Exp
mappendArgs    = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' (Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
`infixApp` [| (<>) |])
                                (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
singletonName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
'}')
                                [Q Exp]
braceCommaArgs
        namedArgs :: Q Exp
namedArgs      = Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
fromStringName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> String -> String
parenInfixConName Name
conName String
" "))
                                  [| (<>) |]
                                  Q Exp
mappendArgs

    Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
      (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args)
      (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
showParenName TextShowFun
tsFun)
                  Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p) [| (>) |] (Int -> Q Exp
integerE Int
appPrec)
                  Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
namedArgs)
      []
makeTextShowForCon Name
p TextShowClass
tsClass TextShowFun
tsFun Map Name (Name, Name)
tvMap
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                   , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
InfixConstructor
                   , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
argTys }) = do
    [Type
alTy, Type
arTy] <- (Type -> Q Type) -> [Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q Type
resolveTypeSynonyms [Type]
argTys
    Name
al <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"argL"
    Name
ar <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"argR"
    Fixity
fi <- Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity (Maybe Fixity -> Fixity) -> Q (Maybe Fixity) -> Q Fixity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q (Maybe Fixity)
reifyFixityCompat Name
conName
    let conPrec :: Int
conPrec  = case Fixity
fi of Fixity Int
prec FixityDirection
_ -> Int
prec
        opName :: String
opName   = Name -> String
nameBase Name
conName
        infixOpE :: Q Exp
infixOpE = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ TextShowFun -> Name
fromStringName TextShowFun
tsFun) (Q Exp -> Q Exp) -> (String -> Q Exp) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$
                     if String -> Bool
isInfixDataCon String
opName
                        then String
" "  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
opName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
                        else String
" `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
opName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"` "

    Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
      (Q Pat -> Name -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> Name -> m Pat -> m Pat
infixP (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
al) Name
conName (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
ar))
      (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
showParenName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p) [| (>) |] (Int -> Q Exp
integerE Int
conPrec))
                   Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Int
-> TextShowClass
-> TextShowFun
-> Name
-> Map Name (Name, Name)
-> Type
-> Name
-> Q Exp
makeTextShowForArg (Int
conPrec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) TextShowClass
tsClass TextShowFun
tsFun Name
conName Map Name (Name, Name)
tvMap Type
alTy Name
al)
                                    [| (<>) |]
                                    (Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
infixOpE
                                              [| (<>) |]
                                              (Int
-> TextShowClass
-> TextShowFun
-> Name
-> Map Name (Name, Name)
-> Type
-> Name
-> Q Exp
makeTextShowForArg (Int
conPrec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) TextShowClass
tsClass TextShowFun
tsFun Name
conName Map Name (Name, Name)
tvMap Type
arTy Name
ar)))
      )
      []

-- | Generates a lambda expression for showbPrec/liftShowbPrec/etc. for an
-- argument of a constructor.
makeTextShowForArg :: Int
                   -> TextShowClass
                   -> TextShowFun
                   -> Name
                   -> TyVarMap
                   -> Type
                   -> Name
                   -> Q Exp
makeTextShowForArg :: Int
-> TextShowClass
-> TextShowFun
-> Name
-> Map Name (Name, Name)
-> Type
-> Name
-> Q Exp
makeTextShowForArg Int
p TextShowClass
_ TextShowFun
tsFun Name
_ Map Name (Name, Name)
_ (ConT Name
tyName) Name
tyExpName =
    Q Exp
showE
  where
    tyVarE, showPrecE :: Q Exp
    tyVarE :: Q Exp
tyVarE    = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tyExpName
    showPrecE :: Q Exp
showPrecE = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowClass -> TextShowFun -> Name
showPrecName TextShowClass
TextShow TextShowFun
tsFun)

    showE :: Q Exp
    showE :: Q Exp
showE =
      case Name -> Map Name PrimShow -> Maybe PrimShow
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tyName Map Name PrimShow
primShowTbl of
        Just PrimShow
ps -> PrimShow -> Q Exp
showPrimE PrimShow
ps
        Maybe PrimShow
Nothing -> Q Exp
showPrecE Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Q Exp
integerE Int
p Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
tyVarE

    showPrimE :: PrimShow -> Q Exp
    showPrimE :: PrimShow -> Q Exp
showPrimE PrimShow{ Q Exp -> Q Exp
primShowBoxer :: Q Exp -> Q Exp
primShowBoxer :: PrimShow -> Q Exp -> Q Exp
primShowBoxer
#if __GLASGOW_HASKELL__ >= 800
                      , TextShowFun -> Q Exp
primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod :: PrimShow -> TextShowFun -> Q Exp
primShowPostfixMod, TextShowFun -> Q Exp -> Q Exp
primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv :: PrimShow -> TextShowFun -> Q Exp -> Q Exp
primShowConv
#endif
                      }
#if __GLASGOW_HASKELL__ >= 800
        -- Starting with GHC 8.0, data types containing unlifted types with
        -- derived Show instances show hashed literals with actual hash signs,
        -- and negative hashed literals are not surrounded with parentheses.
      = TextShowFun -> Q Exp -> Q Exp
primShowConv TextShowFun
tsFun (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Int -> Q Exp
primE Int
0) [| (<>) |] (TextShowFun -> Q Exp
primShowPostfixMod TextShowFun
tsFun)
#else
      = primE p
#endif
      where
        primE :: Int -> Q Exp
        primE :: Int -> Q Exp
primE Int
prec = Q Exp
showPrecE Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Q Exp
integerE Int
prec Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp -> Q Exp
primShowBoxer Q Exp
tyVarE

makeTextShowForArg Int
p TextShowClass
tsClass TextShowFun
tsFun Name
conName Map Name (Name, Name)
tvMap Type
ty Name
tyExpName =
    [| $(TextShowClass
-> TextShowFun
-> Name
-> Map Name (Name, Name)
-> Bool
-> Type
-> Q Exp
makeTextShowForType TextShowClass
tsClass TextShowFun
tsFun Name
conName Map Name (Name, Name)
tvMap Bool
False Type
ty) p $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tyExpName) |]

-- | Generates a lambda expression for showbPrec/liftShowbPrec/etc. for a
-- specific type. The generated expression depends on the number of type variables.
--
-- 1. If the type is of kind * (T), apply showbPrec.
-- 2. If the type is of kind * -> * (T a), apply liftShowbPrec $(makeTextShowForType a)
-- 3. If the type is of kind * -> * -> * (T a b), apply
--    liftShowbPrec2 $(makeTextShowForType a) $(makeTextShowForType b)
makeTextShowForType :: TextShowClass
                    -> TextShowFun
                    -> Name
                    -> TyVarMap
                    -> Bool -- ^ True if we are using the function of type ([a] -> Builder),
                            --   False if we are using the function of type (Int -> a -> Builder).
                    -> Type
                    -> Q Exp
makeTextShowForType :: TextShowClass
-> TextShowFun
-> Name
-> Map Name (Name, Name)
-> Bool
-> Type
-> Q Exp
makeTextShowForType TextShowClass
_ TextShowFun
tsFun Name
_ Map Name (Name, Name)
tvMap Bool
sl (VarT Name
tyName) =
    Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ case Name -> Map Name (Name, Name) -> Maybe (Name, Name)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
tyName Map Name (Name, Name)
tvMap of
         Just (Name
spExp, Name
slExp) -> if Bool
sl then Name
slExp else Name
spExp
         Maybe (Name, Name)
Nothing             -> if Bool
sl then TextShowClass -> TextShowFun -> Name
showListName TextShowClass
TextShow TextShowFun
tsFun
                                      else TextShowClass -> TextShowFun -> Name
showPrecName TextShowClass
TextShow TextShowFun
tsFun
makeTextShowForType TextShowClass
tsClass TextShowFun
tsFun Name
conName Map Name (Name, Name)
tvMap Bool
sl (SigT Type
ty Type
_) =
    TextShowClass
-> TextShowFun
-> Name
-> Map Name (Name, Name)
-> Bool
-> Type
-> Q Exp
makeTextShowForType TextShowClass
tsClass TextShowFun
tsFun Name
conName Map Name (Name, Name)
tvMap Bool
sl Type
ty
makeTextShowForType TextShowClass
tsClass TextShowFun
tsFun Name
conName Map Name (Name, Name)
tvMap Bool
sl (ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
ty) =
    TextShowClass
-> TextShowFun
-> Name
-> Map Name (Name, Name)
-> Bool
-> Type
-> Q Exp
makeTextShowForType TextShowClass
tsClass TextShowFun
tsFun Name
conName Map Name (Name, Name)
tvMap Bool
sl Type
ty
makeTextShowForType TextShowClass
tsClass TextShowFun
tsFun Name
conName Map Name (Name, Name)
tvMap Bool
sl Type
ty = do
    let tyCon :: Type
        tyArgs :: [Type]
        Type
tyCon :| [Type]
tyArgs = Type -> NonEmpty Type
unapplyTy Type
ty

        numLastArgs :: Int
        numLastArgs :: Int
numLastArgs = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (TextShowClass -> Int
forall a. Enum a => a -> Int
fromEnum TextShowClass
tsClass) ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs)

        lhsArgs, rhsArgs :: [Type]
        ([Type]
lhsArgs, [Type]
rhsArgs) = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) [Type]
tyArgs

        tyVarNames :: [Name]
        tyVarNames :: [Name]
tyVarNames = Map Name (Name, Name) -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name (Name, Name)
tvMap

    Bool
itf <- [Name] -> Type -> [Type] -> Q Bool
isInTypeFamilyApp [Name]
tyVarNames Type
tyCon [Type]
tyArgs
    if (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) [Type]
lhsArgs Bool -> Bool -> Bool
|| Bool
itf
       then TextShowClass -> Name -> Q Exp
forall a. TextShowClass -> Name -> Q a
outOfPlaceTyVarError TextShowClass
tsClass Name
conName
       else if (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) [Type]
rhsArgs
               then [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ Bool -> TextShowClass -> TextShowFun -> Name
showPrecOrListName Bool
sl (Int -> TextShowClass
forall a. Enum a => Int -> a
toEnum Int
numLastArgs) TextShowFun
tsFun]
                            [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Bool -> Type -> Q Exp) -> [Bool] -> [Type] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (TextShowClass
-> TextShowFun
-> Name
-> Map Name (Name, Name)
-> Bool
-> Type
-> Q Exp
makeTextShowForType TextShowClass
tsClass TextShowFun
tsFun Name
conName Map Name (Name, Name)
tvMap)
                                       ([Bool] -> [Bool]
forall a. HasCallStack => [a] -> [a]
cycle [Bool
False,Bool
True])
                                       ([Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
interleave [Type]
rhsArgs [Type]
rhsArgs)
               else Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ if Bool
sl then TextShowClass -> TextShowFun -> Name
showListName TextShowClass
TextShow TextShowFun
tsFun
                                 else TextShowClass -> TextShowFun -> Name
showPrecName TextShowClass
TextShow TextShowFun
tsFun

-------------------------------------------------------------------------------
-- Template Haskell reifying and AST manipulation
-------------------------------------------------------------------------------

-- For the given Types, generate an instance context and head. Coming up with
-- the instance type isn't as simple as dropping the last types, as you need to
-- be wary of kinds being instantiated with *.
-- See Note [Type inference in derived instances]
buildTypeInstance :: TextShowClass
                  -- ^ TextShow, TextShow1, or TextShow2
                  -> Name
                  -- ^ The type constructor or data family name
                  -> Cxt
                  -- ^ The datatype context
                  -> [Type]
                  -- ^ The types to instantiate the instance with
                  -> DatatypeVariant
                  -- ^ Are we dealing with a data family instance or not
                  -> Q (Cxt, Type)
buildTypeInstance :: TextShowClass
-> Name -> [Type] -> [Type] -> DatatypeVariant -> Q ([Type], Type)
buildTypeInstance TextShowClass
tsClass Name
tyConName [Type]
dataCxt [Type]
varTysOrig DatatypeVariant
variant = do
    -- Make sure to expand through type/kind synonyms! Otherwise, the
    -- eta-reduction check might get tripped up over type variables in a
    -- synonym that are actually dropped.
    -- (See GHC Trac #11416 for a scenario where this actually happened.)
    [Type]
varTysExp <- (Type -> Q Type) -> [Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q Type
resolveTypeSynonyms [Type]
varTysOrig

    let remainingLength :: Int
        remainingLength :: Int
remainingLength = [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
varTysOrig Int -> Int -> Int
forall a. Num a => a -> a -> a
- TextShowClass -> Int
forall a. Enum a => a -> Int
fromEnum TextShowClass
tsClass

        droppedTysExp :: [Type]
        droppedTysExp :: [Type]
droppedTysExp = Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop Int
remainingLength [Type]
varTysExp

        droppedStarKindStati :: [StarKindStatus]
        droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = (Type -> StarKindStatus) -> [Type] -> [StarKindStatus]
forall a b. (a -> b) -> [a] -> [b]
map Type -> StarKindStatus
canRealizeKindStar [Type]
droppedTysExp

    -- Check there are enough types to drop and that all of them are either of
    -- kind * or kind k (for some kind variable k). If not, throw an error.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
remainingLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| (StarKindStatus -> Bool) -> [StarKindStatus] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (StarKindStatus -> StarKindStatus -> Bool
forall a. Eq a => a -> a -> Bool
== StarKindStatus
NotKindStar) [StarKindStatus]
droppedStarKindStati) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      TextShowClass -> Name -> Q ()
forall a. TextShowClass -> Name -> Q a
derivingKindError TextShowClass
tsClass Name
tyConName

    let droppedKindVarNames :: [Name]
        droppedKindVarNames :: [Name]
droppedKindVarNames = [StarKindStatus] -> [Name]
catKindVarNames [StarKindStatus]
droppedStarKindStati

        -- Substitute kind * for any dropped kind variables
        varTysExpSubst :: [Type]
        varTysExpSubst :: [Type]
varTysExpSubst = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
droppedKindVarNames) [Type]
varTysExp

        remainingTysExpSubst, droppedTysExpSubst :: [Type]
        ([Type]
remainingTysExpSubst, [Type]
droppedTysExpSubst) =
          Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength [Type]
varTysExpSubst

        -- All of the type variables mentioned in the dropped types
        -- (post-synonym expansion)
        droppedTyVarNames :: [Name]
        droppedTyVarNames :: [Name]
droppedTyVarNames = [Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
droppedTysExpSubst

    -- If any of the dropped types were polykinded, ensure that they are of kind *
    -- after substituting * for the dropped kind variables. If not, throw an error.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
hasKindStar [Type]
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      TextShowClass -> Name -> Q ()
forall a. TextShowClass -> Name -> Q a
derivingKindError TextShowClass
tsClass Name
tyConName

    let preds    :: [Maybe Pred]
        kvNames  :: [[Name]]
        kvNames' :: [Name]
        -- Derive instance constraints (and any kind variables which are specialized
        -- to * in those constraints)
        ([Maybe Type]
preds, [[Name]]
kvNames) = [(Maybe Type, [Name])] -> ([Maybe Type], [[Name]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Maybe Type, [Name])] -> ([Maybe Type], [[Name]]))
-> [(Maybe Type, [Name])] -> ([Maybe Type], [[Name]])
forall a b. (a -> b) -> a -> b
$ (Type -> (Maybe Type, [Name])) -> [Type] -> [(Maybe Type, [Name])]
forall a b. (a -> b) -> [a] -> [b]
map (TextShowClass -> Type -> (Maybe Type, [Name])
deriveConstraint TextShowClass
tsClass) [Type]
remainingTysExpSubst
        kvNames' :: [Name]
kvNames' = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Name]]
kvNames

        -- Substitute the kind variables specialized in the constraints with *
        remainingTysExpSubst' :: [Type]
        remainingTysExpSubst' :: [Type]
remainingTysExpSubst' =
          (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
kvNames') [Type]
remainingTysExpSubst

        -- We now substitute all of the specialized-to-* kind variable names with
        -- *, but in the original types, not the synonym-expanded types. The reason
        -- we do this is a superficial one: we want the derived instance to resemble
        -- the datatype written in source code as closely as possible. For example,
        -- for the following data family instance:
        --
        --   data family Fam a
        --   newtype instance Fam String = Fam String
        --
        -- We'd want to generate the instance:
        --
        --   instance C (Fam String)
        --
        -- Not:
        --
        --   instance C (Fam [Char])
        remainingTysOrigSubst :: [Type]
        remainingTysOrigSubst :: [Type]
remainingTysOrigSubst =
          (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar ([Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
List.union [Name]
droppedKindVarNames [Name]
kvNames'))
            ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
take Int
remainingLength [Type]
varTysOrig

    Bool
isDataFamily <-
      case DatatypeVariant
variant of
        DatatypeVariant
Datatype        -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        DatatypeVariant
Newtype         -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        DatatypeVariant
DataInstance    -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        DatatypeVariant
NewtypeInstance -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#if MIN_VERSION_th_abstraction(0,5,0)
        DatatypeVariant
Datatype.TypeData -> Name -> Q Bool
forall a. Name -> Q a
typeDataError Name
tyConName
#endif

    let remainingTysOrigSubst' :: [Type]
        -- See Note [Kind signatures in derived instances] for an explanation
        -- of the isDataFamily check.
        remainingTysOrigSubst' :: [Type]
remainingTysOrigSubst' =
          if Bool
isDataFamily
             then [Type]
remainingTysOrigSubst
             else (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
unSigT [Type]
remainingTysOrigSubst

        instanceCxt :: Cxt
        instanceCxt :: [Type]
instanceCxt = [Maybe Type] -> [Type]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
preds

        instanceType :: Type
        instanceType :: Type
instanceType = Type -> Type -> Type
AppT (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ TextShowClass -> Name
textShowClassName TextShowClass
tsClass)
                     (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Type
applyTyCon Name
tyConName [Type]
remainingTysOrigSubst'

    -- If the datatype context mentions any of the dropped type variables,
    -- we can't derive an instance, so throw an error.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`predMentionsName` [Name]
droppedTyVarNames) [Type]
dataCxt) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      Name -> Type -> Q ()
forall a. Name -> Type -> Q a
datatypeContextError Name
tyConName Type
instanceType
    -- Also ensure the dropped types can be safely eta-reduced. Otherwise,
    -- throw an error.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Type] -> [Type] -> Bool
canEtaReduce [Type]
remainingTysExpSubst' [Type]
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      Type -> Q ()
forall a. Type -> Q a
etaReductionError Type
instanceType
    ([Type], Type) -> Q ([Type], Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
instanceCxt, Type
instanceType)

-- | Attempt to derive a constraint on a Type. If successful, return
-- Just the constraint and any kind variable names constrained to *.
-- Otherwise, return Nothing and the empty list.
--
-- See Note [Type inference in derived instances] for the heuristics used to
-- come up with constraints.
deriveConstraint :: TextShowClass -> Type -> (Maybe Pred, [Name])
deriveConstraint :: TextShowClass -> Type -> (Maybe Type, [Name])
deriveConstraint TextShowClass
tsClass Type
t
  | Bool -> Bool
not (Type -> Bool
isTyVar Type
t) = (Maybe Type
forall a. Maybe a
Nothing, [])
  | Type -> Bool
hasKindStar Type
t   = (Type -> Maybe Type
forall a. a -> Maybe a
Just (Name -> Name -> Type
applyClass ''TextShow Name
tName), [])
  | Bool
otherwise = case Int -> Type -> Maybe [Name]
hasKindVarChain Int
1 Type
t of
      Just [Name]
ns | TextShowClass
tsClass TextShowClass -> TextShowClass -> Bool
forall a. Ord a => a -> a -> Bool
>= TextShowClass
TextShow1
              -> (Type -> Maybe Type
forall a. a -> Maybe a
Just (Name -> Name -> Type
applyClass ''TextShow1 Name
tName), [Name]
ns)
      Maybe [Name]
_ -> case Int -> Type -> Maybe [Name]
hasKindVarChain Int
2 Type
t of
           Just [Name]
ns | TextShowClass
tsClass TextShowClass -> TextShowClass -> Bool
forall a. Eq a => a -> a -> Bool
== TextShowClass
TextShow2
                   -> (Type -> Maybe Type
forall a. a -> Maybe a
Just (Name -> Name -> Type
applyClass ''TextShow2 Name
tName), [Name]
ns)
           Maybe [Name]
_ -> (Maybe Type
forall a. Maybe a
Nothing, [])
  where
    tName :: Name
    tName :: Name
tName = Type -> Name
varTToName Type
t

{-
Note [Kind signatures in derived instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

It is possible to put explicit kind signatures into the derived instances, e.g.,

  instance C a => C (Data (f :: * -> *)) where ...

But it is preferable to avoid this if possible. If we come up with an incorrect
kind signature (which is entirely possible, since our type inferencer is pretty
unsophisticated - see Note [Type inference in derived instances]), then GHC will
flat-out reject the instance, which is quite unfortunate.

Plain old datatypes have the advantage that you can avoid using any kind signatures
at all in their instances. This is because a datatype declaration uses all type
variables, so the types that we use in a derived instance uniquely determine their
kinds. As long as we plug in the right types, the kind inferencer can do the rest
of the work. For this reason, we use unSigT to remove all kind signatures before
splicing in the instance context and head.

Data family instances are trickier, since a data family can have two instances that
are distinguished by kind alone, e.g.,

  data family Fam (a :: k)
  data instance Fam (a :: * -> *)
  data instance Fam (a :: *)

If we dropped the kind signatures for C (Fam a), then GHC will have no way of
knowing which instance we are talking about. To avoid this scenario, we always
include explicit kind signatures in data family instances. There is a chance that
the inferred kind signatures will be incorrect, but if so, we can always fall back
on the make- functions.

Note [Type inference in derived instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Type inference is can be tricky to get right, and we want to avoid recreating the
entirety of GHC's type inferencer in Template Haskell. For this reason, we will
probably never come up with derived instance contexts that are as accurate as
GHC's. But that doesn't mean we can't do anything! There are a couple of simple
things we can do to make instance contexts that work for 80% of use cases:

1. If one of the last type parameters is polykinded, then its kind will be
   specialized to * in the derived instance. We note what kind variable the type
   parameter had and substitute it with * in the other types as well. For example,
   imagine you had

     data Data (a :: k) (b :: k)

   Then you'd want to derived instance to be:

     instance C (Data (a :: *))

   Not:

     instance C (Data (a :: k))

2. We naïvely come up with instance constraints using the following criteria:

   (i)   If there's a type parameter n of kind *, generate a TextShow n constraint.
   (ii)  If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind
         variables), then generate a TextShow1 n constraint, and if k1/k2 are kind
         variables, then substitute k1/k2 with * elsewhere in the types. We must
         consider the case where they are kind variables because you might have a
         scenario like this:

           newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)
             = Compose (f (g a))

         Which would have a derived TextShow1 instance of:

           instance (TextShow1 f, TextShow1 g) => TextShow1 (Compose f g) where ...
   (iii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are
         * or kind variables), then generate a TextShow2 constraint and perform
         kind substitution as in the other cases.
-}

-------------------------------------------------------------------------------
-- Error messages
-------------------------------------------------------------------------------

-- | Either the given data type doesn't have enough type variables, or one of
-- the type variables to be eta-reduced cannot realize kind *.
derivingKindError :: TextShowClass -> Name -> Q a
derivingKindError :: forall a. TextShowClass -> Name -> Q a
derivingKindError TextShowClass
tsClass Name
tyConName = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
Monad.fail
    (String -> Q a) -> (String -> String) -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"Cannot derive well-kinded instance of form ‘"
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
className
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' '
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> (String -> String) -> String -> String
showParen Bool
True
      ( String -> String -> String
showString (Name -> String
nameBase Name
tyConName)
      (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
" ..."
      )
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"‘\n\tClass "
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
className
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
" expects an argument of kind "
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString (Type -> String
forall a. Ppr a => a -> String
pprint (Type -> String) -> (Int -> Type) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
createKindChain (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ TextShowClass -> Int
forall a. Enum a => a -> Int
fromEnum TextShowClass
tsClass)
    (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""
  where
    className :: String
    className :: String
className = Name -> String
nameBase (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ TextShowClass -> Name
textShowClassName TextShowClass
tsClass

-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce
-- function for the criteria it would have to meet).
etaReductionError :: Type -> Q a
etaReductionError :: forall a. Type -> Q a
etaReductionError Type
instanceType = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
Monad.fail (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$
    String
"Cannot eta-reduce to an instance of form \n\tinstance (...) => "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
instanceType

-- | The data type has a DatatypeContext which mentions one of the eta-reduced
-- type variables.
datatypeContextError :: Name -> Type -> Q a
datatypeContextError :: forall a. Name -> Type -> Q a
datatypeContextError Name
dataName Type
instanceType = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
Monad.fail
    (String -> Q a) -> (String -> String) -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"Can't make a derived instance of ‘"
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString (Type -> String
forall a. Ppr a => a -> String
pprint Type
instanceType)
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"‘:\n\tData type ‘"
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString (Name -> String
nameBase Name
dataName)
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"‘ must not have a class context involving the last type argument(s)"
    (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""

-- | The data type mentions one of the n eta-reduced type variables in a place other
-- than the last nth positions of a data type in a constructor's field.
outOfPlaceTyVarError :: TextShowClass -> Name -> Q a
outOfPlaceTyVarError :: forall a. TextShowClass -> Name -> Q a
outOfPlaceTyVarError TextShowClass
tsClass Name
conName = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
Monad.fail
    (String -> Q a) -> (String -> String) -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"Constructor ‘"
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString (Name -> String
nameBase Name
conName)
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"‘ must only use its last "
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Show a => a -> String -> String
shows Int
n
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
" type variable(s) within the last "
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Show a => a -> String -> String
shows Int
n
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
" argument(s) of a data type"
    (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""
  where
    n :: Int
    n :: Int
n = TextShowClass -> Int
forall a. Enum a => a -> Int
fromEnum TextShowClass
tsClass

#if MIN_VERSION_th_abstraction(0,5,0)
-- | We cannot implement class methods at the term level for @type data@
-- declarations, which only exist at the type level.
typeDataError :: Name -> Q a
typeDataError :: forall a. Name -> Q a
typeDataError Name
dataName = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
Monad.fail
  (String -> Q a) -> (String -> String) -> String -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"Cannot derive instance for ‘"
  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString (Name -> String
nameBase Name
dataName)
  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"‘, which is a ‘type data‘ declaration"
  (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
""
#endif

-------------------------------------------------------------------------------
-- Expanding type synonyms
-------------------------------------------------------------------------------

substNameWithKind :: Name -> Kind -> Type -> Type
substNameWithKind :: Name -> Type -> Type -> Type
substNameWithKind Name
n Type
k = Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution (Name -> Type -> Map Name Type
forall k a. k -> a -> Map k a
Map.singleton Name
n Type
k)

substNamesWithKindStar :: [Name] -> Type -> Type
substNamesWithKindStar :: [Name] -> Type -> Type
substNamesWithKindStar [Name]
ns Type
t = (Name -> Type -> Type) -> Type -> [Name] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' ((Name -> Type -> Type -> Type) -> Type -> Name -> Type -> Type
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Type -> Type -> Type
substNameWithKind Type
starK) Type
t [Name]
ns

-------------------------------------------------------------------------------
-- Class-specific constants
-------------------------------------------------------------------------------

-- | A representation of which TextShow variant is being derived.
data TextShowClass = TextShow | TextShow1 | TextShow2
  deriving (Int -> TextShowClass
TextShowClass -> Int
TextShowClass -> [TextShowClass]
TextShowClass -> TextShowClass
TextShowClass -> TextShowClass -> [TextShowClass]
TextShowClass -> TextShowClass -> TextShowClass -> [TextShowClass]
(TextShowClass -> TextShowClass)
-> (TextShowClass -> TextShowClass)
-> (Int -> TextShowClass)
-> (TextShowClass -> Int)
-> (TextShowClass -> [TextShowClass])
-> (TextShowClass -> TextShowClass -> [TextShowClass])
-> (TextShowClass -> TextShowClass -> [TextShowClass])
-> (TextShowClass
    -> TextShowClass -> TextShowClass -> [TextShowClass])
-> Enum TextShowClass
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: TextShowClass -> TextShowClass
succ :: TextShowClass -> TextShowClass
$cpred :: TextShowClass -> TextShowClass
pred :: TextShowClass -> TextShowClass
$ctoEnum :: Int -> TextShowClass
toEnum :: Int -> TextShowClass
$cfromEnum :: TextShowClass -> Int
fromEnum :: TextShowClass -> Int
$cenumFrom :: TextShowClass -> [TextShowClass]
enumFrom :: TextShowClass -> [TextShowClass]
$cenumFromThen :: TextShowClass -> TextShowClass -> [TextShowClass]
enumFromThen :: TextShowClass -> TextShowClass -> [TextShowClass]
$cenumFromTo :: TextShowClass -> TextShowClass -> [TextShowClass]
enumFromTo :: TextShowClass -> TextShowClass -> [TextShowClass]
$cenumFromThenTo :: TextShowClass -> TextShowClass -> TextShowClass -> [TextShowClass]
enumFromThenTo :: TextShowClass -> TextShowClass -> TextShowClass -> [TextShowClass]
Enum, TextShowClass -> TextShowClass -> Bool
(TextShowClass -> TextShowClass -> Bool)
-> (TextShowClass -> TextShowClass -> Bool) -> Eq TextShowClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TextShowClass -> TextShowClass -> Bool
== :: TextShowClass -> TextShowClass -> Bool
$c/= :: TextShowClass -> TextShowClass -> Bool
/= :: TextShowClass -> TextShowClass -> Bool
Eq, Eq TextShowClass
Eq TextShowClass =>
(TextShowClass -> TextShowClass -> Ordering)
-> (TextShowClass -> TextShowClass -> Bool)
-> (TextShowClass -> TextShowClass -> Bool)
-> (TextShowClass -> TextShowClass -> Bool)
-> (TextShowClass -> TextShowClass -> Bool)
-> (TextShowClass -> TextShowClass -> TextShowClass)
-> (TextShowClass -> TextShowClass -> TextShowClass)
-> Ord TextShowClass
TextShowClass -> TextShowClass -> Bool
TextShowClass -> TextShowClass -> Ordering
TextShowClass -> TextShowClass -> TextShowClass
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TextShowClass -> TextShowClass -> Ordering
compare :: TextShowClass -> TextShowClass -> Ordering
$c< :: TextShowClass -> TextShowClass -> Bool
< :: TextShowClass -> TextShowClass -> Bool
$c<= :: TextShowClass -> TextShowClass -> Bool
<= :: TextShowClass -> TextShowClass -> Bool
$c> :: TextShowClass -> TextShowClass -> Bool
> :: TextShowClass -> TextShowClass -> Bool
$c>= :: TextShowClass -> TextShowClass -> Bool
>= :: TextShowClass -> TextShowClass -> Bool
$cmax :: TextShowClass -> TextShowClass -> TextShowClass
max :: TextShowClass -> TextShowClass -> TextShowClass
$cmin :: TextShowClass -> TextShowClass -> TextShowClass
min :: TextShowClass -> TextShowClass -> TextShowClass
Ord)

-- | A representation of which TextShow method is being used to
-- implement something.
data TextShowFun = ShowbPrec | ShowtPrec | ShowtlPrec

fromStringName :: TextShowFun -> Name
fromStringName :: TextShowFun -> Name
fromStringName TextShowFun
ShowbPrec  = 'TB.fromString
fromStringName TextShowFun
ShowtPrec  = 'TS.pack
fromStringName TextShowFun
ShowtlPrec = 'TL.pack

singletonName :: TextShowFun -> Name
singletonName :: TextShowFun -> Name
singletonName TextShowFun
ShowbPrec  = 'TB.singleton
singletonName TextShowFun
ShowtPrec  = 'TS.singleton
singletonName TextShowFun
ShowtlPrec = 'TL.singleton

showParenName :: TextShowFun -> Name
showParenName :: TextShowFun -> Name
showParenName TextShowFun
ShowbPrec  = 'showbParen
showParenName TextShowFun
ShowtPrec  = 'showtParen
showParenName TextShowFun
ShowtlPrec = 'showtlParen

showCommaSpaceName :: TextShowFun -> Name
showCommaSpaceName :: TextShowFun -> Name
showCommaSpaceName TextShowFun
ShowbPrec  = 'showbCommaSpace
showCommaSpaceName TextShowFun
ShowtPrec  = 'showtCommaSpace
showCommaSpaceName TextShowFun
ShowtlPrec = 'showtlCommaSpace

showSpaceName :: TextShowFun -> Name
showSpaceName :: TextShowFun -> Name
showSpaceName TextShowFun
ShowbPrec  = 'showbSpace
showSpaceName TextShowFun
ShowtPrec  = 'showtSpace
showSpaceName TextShowFun
ShowtlPrec = 'showtlSpace

showPrecConstName :: TextShowClass -> TextShowFun -> Name
showPrecConstName :: TextShowClass -> TextShowFun -> Name
showPrecConstName TextShowClass
tsClass  TextShowFun
ShowbPrec  = TextShowClass -> Name
showbPrecConstName TextShowClass
tsClass
showPrecConstName TextShowClass
TextShow TextShowFun
ShowtPrec  = 'showtPrecConst
showPrecConstName TextShowClass
TextShow TextShowFun
ShowtlPrec = 'showtlPrecConst
showPrecConstName TextShowClass
_        TextShowFun
_          = String -> Name
forall a. HasCallStack => String -> a
error String
"showPrecConstName"

showbPrecConstName :: TextShowClass -> Name
showbPrecConstName :: TextShowClass -> Name
showbPrecConstName TextShowClass
TextShow  = 'showbPrecConst
showbPrecConstName TextShowClass
TextShow1 = 'liftShowbPrecConst
showbPrecConstName TextShowClass
TextShow2 = 'liftShowbPrec2Const

textShowClassName :: TextShowClass -> Name
textShowClassName :: TextShowClass -> Name
textShowClassName TextShowClass
TextShow  = ''TextShow
textShowClassName TextShowClass
TextShow1 = ''TextShow1
textShowClassName TextShowClass
TextShow2 = ''TextShow2

showPrecName :: TextShowClass -> TextShowFun -> Name
showPrecName :: TextShowClass -> TextShowFun -> Name
showPrecName TextShowClass
tsClass  TextShowFun
ShowbPrec  = TextShowClass -> Name
showbPrecName TextShowClass
tsClass
showPrecName TextShowClass
TextShow TextShowFun
ShowtPrec  = 'showtPrec
showPrecName TextShowClass
TextShow TextShowFun
ShowtlPrec = 'showtlPrec
showPrecName TextShowClass
_        TextShowFun
_          = String -> Name
forall a. HasCallStack => String -> a
error String
"showPrecName"

showbPrecName :: TextShowClass -> Name
showbPrecName :: TextShowClass -> Name
showbPrecName TextShowClass
TextShow  = 'showbPrec
showbPrecName TextShowClass
TextShow1 = 'liftShowbPrec
showbPrecName TextShowClass
TextShow2 = 'liftShowbPrec2

showListName :: TextShowClass -> TextShowFun -> Name
showListName :: TextShowClass -> TextShowFun -> Name
showListName TextShowClass
tsClass  TextShowFun
ShowbPrec  = TextShowClass -> Name
showbListName TextShowClass
tsClass
showListName TextShowClass
TextShow TextShowFun
ShowtPrec  = 'showtPrec
showListName TextShowClass
TextShow TextShowFun
ShowtlPrec = 'showtlPrec
showListName TextShowClass
_        TextShowFun
_          = String -> Name
forall a. HasCallStack => String -> a
error String
"showListName"

showbListName :: TextShowClass -> Name
showbListName :: TextShowClass -> Name
showbListName TextShowClass
TextShow  = 'showbList
showbListName TextShowClass
TextShow1 = 'liftShowbList
showbListName TextShowClass
TextShow2 = 'liftShowbList2

showPrecOrListName :: Bool -- ^ showbListName if True, showbPrecName if False
                   -> TextShowClass
                   -> TextShowFun
                   -> Name
showPrecOrListName :: Bool -> TextShowClass -> TextShowFun -> Name
showPrecOrListName Bool
False = TextShowClass -> TextShowFun -> Name
showPrecName
showPrecOrListName Bool
True  = TextShowClass -> TextShowFun -> Name
showListName

-- | A type-restricted version of 'const'. This is useful when generating the lambda
-- expression in 'makeShowbPrec' for a data type with only nullary constructors (since
-- the expression wouldn't depend on the precedence). For example, if you had @data
-- Nullary = Nullary@ and attempted to run @$(makeShowbPrec ''Nullary) Nullary@, simply
-- ignoring the precedence argument would cause the type signature of @$(makeShowbPrec
-- ''Nullary)@ to be @a -> Nullary -> Builder@, not @Int -> Nullary -> Builder@.
showbPrecConst :: Builder
               -> Int -> a -> Builder
showbPrecConst :: forall a. Builder -> Int -> a -> Builder
showbPrecConst Builder
b Int
_ a
_ = Builder
b

showtPrecConst :: TS.Text
               -> Int -> a -> TS.Text
showtPrecConst :: forall a. Text -> Int -> a -> Text
showtPrecConst Text
t Int
_ a
_ = Text
t

showtlPrecConst :: TL.Text
                -> Int -> a -> TL.Text
showtlPrecConst :: forall a. Text -> Int -> a -> Text
showtlPrecConst Text
tl Int
_ a
_ = Text
tl

liftShowbPrecConst :: Builder
                   -> (Int -> a -> Builder) -> ([a] -> Builder)
                   -> Int -> f a -> Builder
liftShowbPrecConst :: forall a (f :: * -> *).
Builder
-> (Int -> a -> Builder)
-> ([a] -> Builder)
-> Int
-> f a
-> Builder
liftShowbPrecConst Builder
b Int -> a -> Builder
_ [a] -> Builder
_ Int
_ f a
_ = Builder
b

liftShowbPrec2Const :: Builder
                    -> (Int -> a -> Builder) -> ([a] -> Builder)
                    -> (Int -> b -> Builder) -> ([b] -> Builder)
                    -> Int -> f a b -> Builder
liftShowbPrec2Const :: forall a b (f :: * -> * -> *).
Builder
-> (Int -> a -> Builder)
-> ([a] -> Builder)
-> (Int -> b -> Builder)
-> ([b] -> Builder)
-> Int
-> f a b
-> Builder
liftShowbPrec2Const Builder
b Int -> a -> Builder
_ [a] -> Builder
_ Int -> b -> Builder
_ [b] -> Builder
_ Int
_ f a b
_ = Builder
b

-------------------------------------------------------------------------------
-- StarKindStatus
-------------------------------------------------------------------------------

-- | Whether a type is not of kind *, is of kind *, or is a kind variable.
data StarKindStatus = NotKindStar
                    | KindStar
                    | IsKindVar Name
  deriving StarKindStatus -> StarKindStatus -> Bool
(StarKindStatus -> StarKindStatus -> Bool)
-> (StarKindStatus -> StarKindStatus -> Bool) -> Eq StarKindStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StarKindStatus -> StarKindStatus -> Bool
== :: StarKindStatus -> StarKindStatus -> Bool
$c/= :: StarKindStatus -> StarKindStatus -> Bool
/= :: StarKindStatus -> StarKindStatus -> Bool
Eq

-- | Does a Type have kind * or k (for some kind variable k)?
canRealizeKindStar :: Type -> StarKindStatus
canRealizeKindStar :: Type -> StarKindStatus
canRealizeKindStar Type
t
  | Type -> Bool
hasKindStar Type
t = StarKindStatus
KindStar
  | Bool
otherwise = case Type
t of
                     SigT Type
_ (VarT Name
k) -> Name -> StarKindStatus
IsKindVar Name
k
                     Type
_               -> StarKindStatus
NotKindStar

-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.
-- Otherwise, returns 'Nothing'.
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName (IsKindVar Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
starKindStatusToName StarKindStatus
_             = Maybe Name
forall a. Maybe a
Nothing

-- | Concat together all of the StarKindStatuses that are IsKindVar and extract
-- the kind variables' Names out.
catKindVarNames :: [StarKindStatus] -> [Name]
catKindVarNames :: [StarKindStatus] -> [Name]
catKindVarNames = (StarKindStatus -> Maybe Name) -> [StarKindStatus] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe StarKindStatus -> Maybe Name
starKindStatusToName

-------------------------------------------------------------------------------
-- PrimShow
-------------------------------------------------------------------------------

data PrimShow = PrimShow
  { PrimShow -> Q Exp -> Q Exp
primShowBoxer      :: Q Exp -> Q Exp
  , PrimShow -> TextShowFun -> Q Exp
primShowPostfixMod :: TextShowFun -> Q Exp
  , PrimShow -> TextShowFun -> Q Exp -> Q Exp
primShowConv       :: TextShowFun -> Q Exp -> Q Exp
  }

primShowTbl :: Map Name PrimShow
primShowTbl :: Map Name PrimShow
primShowTbl = [(Name, PrimShow)] -> Map Name PrimShow
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (''Char#,   PrimShow
                    { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'C#)
                    , primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
oneHashE
                    , primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv       = \TextShowFun
_ Q Exp
x -> Q Exp
x
                    })
    , (''Double#, PrimShow
                    { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'D#)
                    , primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
twoHashE
                    , primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv       = \TextShowFun
_ Q Exp
x -> Q Exp
x
                    })
    , (''Float#,  PrimShow
                    { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'F#)
                    , primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
oneHashE
                    , primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv       = \TextShowFun
_ Q Exp
x -> Q Exp
x
                    })
    , (''Int#,    PrimShow
                    { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'I#)
                    , primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
oneHashE
                    , primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv       = \TextShowFun
_ Q Exp
x -> Q Exp
x
                    })
    , (''Word#,   PrimShow
                    { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'W#)
                    , primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
twoHashE
                    , primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv       = \TextShowFun
_ Q Exp
x -> Q Exp
x
                    })
#if MIN_VERSION_base(4,19,0)
    , (''Int8#,   PrimShow
                    { primShowBoxer      = appE (conE 'I8#)
                    , primShowPostfixMod = extendedLitE "Int8"
                    , primShowConv       = \_ x -> x
                    })
    , (''Int16#,  PrimShow
                    { primShowBoxer      = appE (conE 'I16#)
                    , primShowPostfixMod = extendedLitE "Int16"
                    , primShowConv       = \_ x -> x
                    })
    , (''Int32#,  PrimShow
                    { primShowBoxer      = appE (conE 'I32#)
                    , primShowPostfixMod = extendedLitE "Int32"
                    , primShowConv       = \_ x -> x
                    })
    , (''Int64#,  PrimShow
                    { primShowBoxer      = appE (conE 'I64#)
                    , primShowPostfixMod = extendedLitE "Int64"
                    , primShowConv       = \_ x -> x
                    })
    , (''Word8#,  PrimShow
                    { primShowBoxer      = appE (conE 'W8#)
                    , primShowPostfixMod = extendedLitE "Word8"
                    , primShowConv       = \_ x -> x
                    })
    , (''Word16#, PrimShow
                    { primShowBoxer      = appE (conE 'W16#)
                    , primShowPostfixMod = extendedLitE "Word16"
                    , primShowConv       = \_ x -> x
                    })
    , (''Word32#, PrimShow
                    { primShowBoxer      = appE (conE 'W32#)
                    , primShowPostfixMod = extendedLitE "Word32"
                    , primShowConv       = \_ x -> x
                    })
    , (''Word64#, PrimShow
                    { primShowBoxer      = appE (conE 'W64#)
                    , primShowPostfixMod = extendedLitE "Word64"
                    , primShowConv       = \_ x -> x
                    })
#else
# if MIN_VERSION_base(4,13,0)
    , (''Int8#,   PrimShow
                    { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'I#) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
int8ToIntHashValName)
                    , primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
oneHashE
                    , primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv       = Name -> TextShowFun -> Q Exp -> Q Exp
mkNarrowE Name
intToInt8HashValName
                    })
    , (''Int16#,  PrimShow
                    { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'I#) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
int16ToIntHashValName)
                    , primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
oneHashE
                    , primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv       = Name -> TextShowFun -> Q Exp -> Q Exp
mkNarrowE Name
intToInt16HashValName
                    })
    , (''Word8#,  PrimShow
                    { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'W#) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
word8ToWordHashValName)
                    , primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
twoHashE
                    , primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv       = Name -> TextShowFun -> Q Exp -> Q Exp
mkNarrowE Name
wordToWord8HashValName
                    })
    , (''Word16#, PrimShow
                    { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'W#) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
word16ToWordHashValName)
                    , primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
twoHashE
                    , primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv       = Name -> TextShowFun -> Q Exp -> Q Exp
mkNarrowE Name
wordToWord16HashValName
                    })
# endif
# if MIN_VERSION_base(4,16,0)
    , (''Int32#,  PrimShow
                    { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'I#) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'int32ToInt#)
                    , primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
oneHashE
                    , primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv       = Name -> TextShowFun -> Q Exp -> Q Exp
mkNarrowE 'intToInt32#
                    })
    , (''Word32#, PrimShow
                    { primShowBoxer :: Q Exp -> Q Exp
primShowBoxer      = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'W#) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'word32ToWord#)
                    , primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
twoHashE
                    , primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv       = Name -> TextShowFun -> Q Exp -> Q Exp
mkNarrowE 'wordToWord32#
                    })
# endif
#endif
    ]

#if MIN_VERSION_base(4,13,0) && !(MIN_VERSION_base(4,19,0))
mkNarrowE :: Name -> TextShowFun -> Q Exp -> Q Exp
mkNarrowE :: Name -> TextShowFun -> Q Exp -> Q Exp
mkNarrowE Name
narrowName TextShowFun
tsFun Q Exp
e =
  (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
`infixApp` [| (<>) |])
        (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
singletonName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
')')
        [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
fromStringName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Char
'('Char -> String -> String
forall a. a -> [a] -> [a]
:Name -> String
nameBase Name
narrowName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ")
        , Q Exp
e
        ]

int8ToIntHashValName :: Name
int8ToIntHashValName :: Name
int8ToIntHashValName =
# if MIN_VERSION_base(4,16,0)
  'int8ToInt#
# else
  'extendInt8#
# endif

int16ToIntHashValName :: Name
int16ToIntHashValName :: Name
int16ToIntHashValName =
# if MIN_VERSION_base(4,16,0)
  'int16ToInt#
# else
  'extendInt16#
# endif

intToInt8HashValName :: Name
intToInt8HashValName :: Name
intToInt8HashValName =
# if MIN_VERSION_base(4,16,0)
  'intToInt8#
# else
  'narrowInt8#
# endif

intToInt16HashValName :: Name
intToInt16HashValName :: Name
intToInt16HashValName =
# if MIN_VERSION_base(4,16,0)
  'intToInt16#
# else
  'narrowInt16#
# endif

word8ToWordHashValName :: Name
word8ToWordHashValName :: Name
word8ToWordHashValName =
# if MIN_VERSION_base(4,16,0)
  'word8ToWord#
# else
  'extendWord8#
# endif

word16ToWordHashValName :: Name
word16ToWordHashValName :: Name
word16ToWordHashValName =
# if MIN_VERSION_base(4,16,0)
  'word16ToWord#
# else
  'extendWord16#
# endif

wordToWord8HashValName :: Name
wordToWord8HashValName :: Name
wordToWord8HashValName =
# if MIN_VERSION_base(4,16,0)
  'wordToWord8#
# else
  'narrowWord8#
# endif

wordToWord16HashValName :: Name
wordToWord16HashValName :: Name
wordToWord16HashValName =
# if MIN_VERSION_base(4,16,0)
  'wordToWord16#
# else
  'narrowWord16#
# endif
#endif

oneHashE, twoHashE :: TextShowFun -> Q Exp
oneHashE :: TextShowFun -> Q Exp
oneHashE TextShowFun
tsFun = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
singletonName TextShowFun
tsFun)  Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Char -> Q Exp
charE Char
'#'
twoHashE :: TextShowFun -> Q Exp
twoHashE TextShowFun
tsFun = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (TextShowFun -> Name
fromStringName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE String
"##"

#if MIN_VERSION_base(4,19,0)
extendedLitE :: String -> TextShowFun -> Q Exp
extendedLitE suffix tsFun = varE (fromStringName tsFun) `appE` stringE ("#" ++ suffix)
#endif

-------------------------------------------------------------------------------
-- Assorted utilities
-------------------------------------------------------------------------------

integerE :: Int -> Q Exp
integerE :: Int -> Q Exp
integerE = Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> (Int -> Lit) -> Int -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
integerL (Integer -> Lit) -> (Int -> Integer) -> Int -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

charE :: Char -> Q Exp
charE :: Char -> Q Exp
charE = Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> (Char -> Lit) -> Char -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Lit
charL

-- | Returns True if a Type has kind *.
hasKindStar :: Type -> Bool
hasKindStar :: Type -> Bool
hasKindStar VarT{}         = Bool
True
hasKindStar (SigT Type
_ Type
StarT) = Bool
True
hasKindStar Type
_              = Bool
False

-- Returns True is a kind is equal to *, or if it is a kind variable.
isStarOrVar :: Kind -> Bool
isStarOrVar :: Type -> Bool
isStarOrVar Type
StarT  = Bool
True
isStarOrVar VarT{} = Bool
True
isStarOrVar Type
_      = Bool
False

-- Generate a list of fresh names with a common prefix, and numbered suffixes.
newNameList :: String -> Int -> Q [Name]
newNameList :: String -> Int -> Q [Name]
newNameList String
prefix Int
n = (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> (Int -> String) -> Int -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
n]

-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form
-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or
-- kind variables.
hasKindVarChain :: Int -> Type -> Maybe [Name]
hasKindVarChain :: Int -> Type -> Maybe [Name]
hasKindVarChain Int
kindArrows Type
t =
  let uk :: NonEmpty Type
uk = Type -> NonEmpty Type
uncurryTy (Type -> Type
tyKind Type
t)
  in if (NonEmpty Type -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty Type
uk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
kindArrows) Bool -> Bool -> Bool
&& (Type -> Bool) -> NonEmpty Type -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isStarOrVar NonEmpty Type
uk
        then [Name] -> Maybe [Name]
forall a. a -> Maybe a
Just ((Type -> [Name]) -> NonEmpty Type -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables NonEmpty Type
uk)
        else Maybe [Name]
forall a. Maybe a
Nothing

-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.
tyKind :: Type -> Kind
tyKind :: Type -> Type
tyKind (SigT Type
_ Type
k) = Type
k
tyKind Type
_          = Type
starK

-- | A mapping of type variable Names to their show function Names. For example, in a
-- TextShow2 declaration, a TyVarMap might look like (a ~> sp1, b ~> sp2), where
-- a and b are the last two type variables of the datatype, and sp1 and sp2 are the two
-- functions which show their respective type variables.
type TyVarMap = Map Name (Name, Name)

-- | Checks if a 'Name' represents a tuple type constructor (other than '()')
isNonUnitTuple :: Name -> Bool
isNonUnitTuple :: Name -> Bool
isNonUnitTuple = String -> Bool
isTupleString (String -> Bool) -> (Name -> String) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase

-- | Parenthesize an infix constructor name if it is being applied as a prefix
-- function (e.g., data Amp a = (:&) a a)
parenInfixConName :: Name -> ShowS
parenInfixConName :: Name -> String -> String
parenInfixConName Name
conName =
    let conNameBase :: String
conNameBase = Name -> String
nameBase Name
conName
     in Bool -> (String -> String) -> String -> String
showParen (String -> Bool
isInfixDataCon String
conNameBase) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
showString String
conNameBase

-- | Applies a typeclass constraint to a type.
applyClass :: Name -> Name -> Pred
#if MIN_VERSION_template_haskell(2,10,0)
applyClass :: Name -> Name -> Type
applyClass Name
con Name
t = Type -> Type -> Type
AppT (Name -> Type
ConT Name
con) (Name -> Type
VarT Name
t)
#else
applyClass con t = ClassP con [VarT t]
#endif

-- | Checks to see if the last types in a data family instance can be safely eta-
-- reduced (i.e., dropped), given the other types. This checks for three conditions:
--
-- (1) All of the dropped types are type variables
-- (2) All of the dropped types are distinct
-- (3) None of the remaining types mention any of the dropped types
canEtaReduce :: [Type] -> [Type] -> Bool
canEtaReduce :: [Type] -> [Type] -> Bool
canEtaReduce [Type]
remaining [Type]
dropped =
       (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isTyVar [Type]
dropped
    Bool -> Bool -> Bool
&& [Name] -> Bool
forall a. Ord a => [a] -> Bool
allDistinct [Name]
droppedNames -- Make sure not to pass something of type [Type], since Type
                                -- didn't have an Ord instance until template-haskell-2.10.0.0
    Bool -> Bool -> Bool
&& Bool -> Bool
not ((Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
droppedNames) [Type]
remaining)
  where
    droppedNames :: [Name]
    droppedNames :: [Name]
droppedNames = (Type -> Name) -> [Type] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName [Type]
dropped

-- | Extract Just the Name from a type variable. If the argument Type is not a
-- type variable, return Nothing.
varTToName_maybe :: Type -> Maybe Name
varTToName_maybe :: Type -> Maybe Name
varTToName_maybe (VarT Name
n)   = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
varTToName_maybe (SigT Type
t Type
_) = Type -> Maybe Name
varTToName_maybe Type
t
varTToName_maybe Type
_          = Maybe Name
forall a. Maybe a
Nothing

-- | Extract the Name from a type variable. If the argument Type is not a
-- type variable, throw an error.
varTToName :: Type -> Name
varTToName :: Type -> Name
varTToName = Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe (String -> Name
forall a. HasCallStack => String -> a
error String
"Not a type variable!") (Maybe Name -> Name) -> (Type -> Maybe Name) -> Type -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe Name
varTToName_maybe

-- | Peel off a kind signature from a Type (if it has one).
unSigT :: Type -> Type
unSigT :: Type -> Type
unSigT (SigT Type
t Type
_) = Type
t
unSigT Type
t          = Type
t

-- | Is the given type a variable?
isTyVar :: Type -> Bool
isTyVar :: Type -> Bool
isTyVar (VarT Name
_)   = Bool
True
isTyVar (SigT Type
t Type
_) = Type -> Bool
isTyVar Type
t
isTyVar Type
_          = Bool
False

-- | Detect if a Name in a list of provided Names occurs as an argument to some
-- type family. This makes an effort to exclude /oversaturated/ arguments to
-- type families. For instance, if one declared the following type family:
--
-- @
-- type family F a :: Type -> Type
-- @
--
-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@,
-- but not @b@.
isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool
isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool
isInTypeFamilyApp [Name]
names Type
tyFun [Type]
tyArgs =
  case Type
tyFun of
    ConT Name
tcName -> Name -> Q Bool
go Name
tcName
    Type
_           -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where
    go :: Name -> Q Bool
    go :: Name -> Q Bool
go Name
tcName = do
      Info
info <- Name -> Q Info
reify Name
tcName
      case Info
info of
#if MIN_VERSION_template_haskell(2,11,0)
        FamilyI (OpenTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndr ()]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_)) [Dec]
_
          -> [TyVarBndr ()] -> Q Bool
forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndr ()]
bndrs
#else
        FamilyI (FamilyD TypeFam _ bndrs _) _
          -> withinFirstArgs bndrs
#endif

#if MIN_VERSION_template_haskell(2,11,0)
        FamilyI (ClosedTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndr ()]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) [Dec]
_
          -> [TyVarBndr ()] -> Q Bool
forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndr ()]
bndrs
#else
        FamilyI (ClosedTypeFamilyD _ bndrs _ _) _
          -> withinFirstArgs bndrs
#endif

        Info
_ -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      where
        withinFirstArgs :: [a] -> Q Bool
        withinFirstArgs :: forall a. [a] -> Q Bool
withinFirstArgs [a]
bndrs =
          let firstArgs :: [Type]
firstArgs = Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
bndrs) [Type]
tyArgs
              argFVs :: [Name]
argFVs    = [Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
firstArgs
          in Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Q Bool) -> Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
argFVs) [Name]
names

-- | Are all of the items in a list (which have an ordering) distinct?
--
-- This uses Set (as opposed to nub) for better asymptotic time complexity.
allDistinct :: Ord a => [a] -> Bool
allDistinct :: forall a. Ord a => [a] -> Bool
allDistinct = Set a -> [a] -> Bool
forall a. Ord a => Set a -> [a] -> Bool
allDistinct' Set a
forall a. Set a
Set.empty
  where
    allDistinct' :: Ord a => Set a -> [a] -> Bool
    allDistinct' :: forall a. Ord a => Set a -> [a] -> Bool
allDistinct' Set a
uniqs (a
x:[a]
xs)
        | a
x a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
uniqs = Bool
False
        | Bool
otherwise            = Set a -> [a] -> Bool
forall a. Ord a => Set a -> [a] -> Bool
allDistinct' (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
uniqs) [a]
xs
    allDistinct' Set a
_ [a]
_           = Bool
True

-- | Does the given type mention any of the Names in the list?
mentionsName :: Type -> [Name] -> Bool
mentionsName :: Type -> [Name] -> Bool
mentionsName = Type -> [Name] -> Bool
go
  where
    go :: Type -> [Name] -> Bool
    go :: Type -> [Name] -> Bool
go (AppT Type
t1 Type
t2) [Name]
names = Type -> [Name] -> Bool
go Type
t1 [Name]
names Bool -> Bool -> Bool
|| Type -> [Name] -> Bool
go Type
t2 [Name]
names
    go (SigT Type
t Type
k)   [Name]
names = Type -> [Name] -> Bool
go Type
t  [Name]
names Bool -> Bool -> Bool
|| Type -> [Name] -> Bool
go Type
k  [Name]
names
    go (VarT Name
n)     [Name]
names = Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
names
    go Type
_            [Name]
_     = Bool
False

-- | Does an instance predicate mention any of the Names in the list?
predMentionsName :: Pred -> [Name] -> Bool
#if MIN_VERSION_template_haskell(2,10,0)
predMentionsName :: Type -> [Name] -> Bool
predMentionsName = Type -> [Name] -> Bool
mentionsName
#else
predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys
predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names
#endif

-- | Construct a type via curried application.
applyTy :: Type -> [Type] -> Type
applyTy :: Type -> [Type] -> Type
applyTy = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT

-- | Fully applies a type constructor to its type variables.
applyTyCon :: Name -> [Type] -> Type
applyTyCon :: Name -> [Type] -> Type
applyTyCon = Type -> [Type] -> Type
applyTy (Type -> [Type] -> Type)
-> (Name -> Type) -> Name -> [Type] -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
ConT

-- | Split an applied type into its individual components. For example, this:
--
-- @
-- Either Int Char
-- @
--
-- would split to this:
--
-- @
-- [Either, Int, Char]
-- @
unapplyTy :: Type -> NonEmpty Type
unapplyTy :: Type -> NonEmpty Type
unapplyTy Type
ty = Type -> Type -> [Type] -> NonEmpty Type
go Type
ty Type
ty []
  where
    go :: Type -> Type -> [Type] -> NonEmpty Type
    go :: Type -> Type -> [Type] -> NonEmpty Type
go Type
_      (AppT Type
ty1 Type
ty2)     [Type]
args = Type -> Type -> [Type] -> NonEmpty Type
go Type
ty1 Type
ty1 (Type
ty2Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
args)
    go Type
origTy (SigT Type
ty' Type
_)       [Type]
args = Type -> Type -> [Type] -> NonEmpty Type
go Type
origTy Type
ty' [Type]
args
#if MIN_VERSION_template_haskell(2,11,0)
    go Type
origTy (InfixT Type
ty1 Name
n Type
ty2) [Type]
args = Type -> Type -> [Type] -> NonEmpty Type
go Type
origTy (Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
ty1 Type -> Type -> Type
`AppT` Type
ty2) [Type]
args
    go Type
origTy (ParensT Type
ty')      [Type]
args = Type -> Type -> [Type] -> NonEmpty Type
go Type
origTy Type
ty' [Type]
args
#endif
    go Type
origTy Type
_                  [Type]
args = Type
origTy Type -> [Type] -> NonEmpty Type
forall a. a -> [a] -> NonEmpty a
:| [Type]
args

-- | Split a type signature by the arrows on its spine. For example, this:
--
-- @
-- (Int -> String) -> Char -> ()
-- @
--
-- would split to this:
--
-- @
-- [Int -> String, Char, ()]
-- @
uncurryTy :: Type -> NonEmpty Type
uncurryTy :: Type -> NonEmpty Type
uncurryTy (AppT (AppT Type
ArrowT Type
t1) Type
t2) = Type
t1 Type -> NonEmpty Type -> NonEmpty Type
forall a. a -> NonEmpty a -> NonEmpty a
<| Type -> NonEmpty Type
uncurryTy Type
t2
uncurryTy (SigT Type
t Type
_)                 = Type -> NonEmpty Type
uncurryTy Type
t
uncurryTy (ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
t)            = Type -> NonEmpty Type
uncurryTy Type
t
uncurryTy Type
t                          = Type
t Type -> [Type] -> NonEmpty Type
forall a. a -> [a] -> NonEmpty a
:| []

createKindChain :: Int -> Kind
createKindChain :: Int -> Type
createKindChain = Type -> Int -> Type
go Type
starK
  where
    go :: Kind -> Int -> Kind
    go :: Type -> Int -> Type
go Type
k !Int
0 = Type
k
    go Type
k !Int
n = Type -> Int -> Type
go (Type -> Type -> Type
arrowKCompat Type
starK Type
k) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

isNullaryCon :: ConstructorInfo -> Bool
isNullaryCon :: ConstructorInfo -> Bool
isNullaryCon (ConstructorInfo { constructorFields :: ConstructorInfo -> [Type]
constructorFields = [] }) = Bool
True
isNullaryCon ConstructorInfo
_                                            = Bool
False

interleave :: [a] -> [a] -> [a]
interleave :: forall a. [a] -> [a] -> [a]
interleave (a
a1:[a]
a1s) (a
a2:[a]
a2s) = a
a1a -> [a] -> [a]
forall a. a -> [a] -> [a]
:a
a2a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
interleave [a]
a1s [a]
a2s
interleave [a]
_        [a]
_        = []

{-
Note [Matching functions with GADT type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

When deriving TextShow2, there is a tricky corner case to consider:

  data Both a b where
    BothCon :: x -> x -> Both x x

Which show functions should be applied to which arguments of BothCon? We have a
choice, since both the function of type (Int -> a -> Builder) and of type
(Int -> b -> Builder) can be applied to either argument. In such a scenario, the
second show function takes precedence over the first show function, so the
derived TextShow2 instance would be:

  instance TextShow Both where
    liftShowsPrec2 sp1 sp2 p (BothCon x1 x2) =
      showbParen (p > appPrec) $
        "BothCon " <> sp2 appPrec1 x1 <> showbSpace <> sp2 appPrec1 x2

This is not an arbitrary choice, as this definition ensures that
liftShowsPrec2 showsPrec = liftShowsPrec for a derived TextShow1 instance for
Both.
-}