{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TemplateHaskell #-}
module TextShow.TH.Internal (
deriveTextShow
, deriveTextShow1
, deriveTextShow2
, makeShowt
, makeShowtl
, makeShowtPrec
, makeShowtlPrec
, makeShowtList
, makeShowtlList
, makeShowb
, makeShowbPrec
, makeShowbList
, makePrintT
, makePrintTL
, makeHPrintT
, makeHPrintTL
, makeLiftShowbPrec
, makeShowbPrec1
, makeLiftShowbPrec2
, makeShowbPrec2
, Options(..)
, defaultOptions
, GenTextMethods(..)
, deriveTextShowOptions
, deriveTextShow1Options
, deriveTextShow2Options
) where
import Control.Monad (unless, when)
import Data.Foldable.Compat
import Data.List.Compat
import qualified Data.List.NonEmpty.Compat as NE (reverse)
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#
, extendInt8#, extendInt16#, extendWord8#, extendWord16#
#endif
)
import GHC.Show (appPrec, appPrec1)
import Language.Haskell.TH.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)
deriveTextShow :: Name -> Q [Dec]
deriveTextShow :: Name -> Q [Dec]
deriveTextShow = Options -> Name -> Q [Dec]
deriveTextShowOptions Options
defaultOptions
deriveTextShowOptions :: Options -> Name -> Q [Dec]
deriveTextShowOptions :: Options -> Name -> Q [Dec]
deriveTextShowOptions = TextShowClass -> Options -> Name -> Q [Dec]
deriveTextShowClass TextShowClass
TextShow
deriveTextShow1 :: Name -> Q [Dec]
deriveTextShow1 :: Name -> Q [Dec]
deriveTextShow1 = Options -> Name -> Q [Dec]
deriveTextShow1Options Options
defaultOptions
deriveTextShow1Options :: Options -> Name -> Q [Dec]
deriveTextShow1Options :: Options -> Name -> Q [Dec]
deriveTextShow1Options = TextShowClass -> Options -> Name -> Q [Dec]
deriveTextShowClass TextShowClass
TextShow1
deriveTextShow2 :: Name -> Q [Dec]
deriveTextShow2 :: Name -> Q [Dec]
deriveTextShow2 = Options -> Name -> Q [Dec]
deriveTextShow2Options Options
defaultOptions
deriveTextShow2Options :: Options -> Name -> Q [Dec]
deriveTextShow2Options :: Options -> Name -> Q [Dec]
deriveTextShow2Options = TextShowClass -> Options -> Name -> Q [Dec]
deriveTextShowClass TextShowClass
TextShow2
makeShowt :: Name -> Q Exp
makeShowt :: Name -> Q Exp
makeShowt name :: Name
name = Name -> Q Exp
makeShowtPrec Name
name Q Exp -> Q Exp -> Q Exp
`appE` Int -> Q Exp
integerE 0
makeShowtl :: Name -> Q Exp
makeShowtl :: Name -> Q Exp
makeShowtl name :: Name
name = Name -> Q Exp
makeShowtlPrec Name
name Q Exp -> Q Exp -> Q Exp
`appE` Int -> Q Exp
integerE 0
makeShowtPrec :: Name -> Q Exp
makeShowtPrec :: Name -> Q Exp
makeShowtPrec = TextShowClass -> TextShowFun -> Options -> Name -> Q Exp
makeShowbPrecClass TextShowClass
TextShow TextShowFun
ShowtPrec Options
defaultOptions
makeShowtlPrec :: Name -> Q Exp
makeShowtlPrec :: Name -> Q Exp
makeShowtlPrec = TextShowClass -> TextShowFun -> Options -> Name -> Q Exp
makeShowbPrecClass TextShowClass
TextShow TextShowFun
ShowtlPrec Options
defaultOptions
makeShowtList :: Name -> Q Exp
makeShowtList :: Name -> Q Exp
makeShowtList name :: Name
name = [| toStrict . $(makeShowtlList name) |]
makeShowtlList :: Name -> Q Exp
makeShowtlList :: Name -> Q Exp
makeShowtlList name :: Name
name = [| toLazyText . $(makeShowbList name) |]
makeShowb :: Name -> Q Exp
makeShowb :: Name -> Q Exp
makeShowb name :: Name
name = Name -> Q Exp
makeShowbPrec Name
name Q Exp -> Q Exp -> Q Exp
`appE` Int -> Q Exp
integerE 0
makeShowbPrec :: Name -> Q Exp
makeShowbPrec :: Name -> Q Exp
makeShowbPrec = TextShowClass -> TextShowFun -> Options -> Name -> Q Exp
makeShowbPrecClass TextShowClass
TextShow TextShowFun
ShowbPrec Options
defaultOptions
makeLiftShowbPrec :: Name -> Q Exp
makeLiftShowbPrec :: Name -> Q Exp
makeLiftShowbPrec = TextShowClass -> TextShowFun -> Options -> Name -> Q Exp
makeShowbPrecClass TextShowClass
TextShow1 TextShowFun
ShowbPrec Options
defaultOptions
makeShowbPrec1 :: Name -> Q Exp
makeShowbPrec1 :: Name -> Q Exp
makeShowbPrec1 name :: Name
name = [| $(makeLiftShowbPrec name) showbPrec showbList |]
makeLiftShowbPrec2 :: Name -> Q Exp
makeLiftShowbPrec2 :: Name -> Q Exp
makeLiftShowbPrec2 = TextShowClass -> TextShowFun -> Options -> Name -> Q Exp
makeShowbPrecClass TextShowClass
TextShow2 TextShowFun
ShowbPrec Options
defaultOptions
makeShowbPrec2 :: Name -> Q Exp
makeShowbPrec2 :: Name -> Q Exp
makeShowbPrec2 name :: Name
name = [| $(makeLiftShowbPrec2 name) showbPrec showbList showbPrec showbList |]
makeShowbList :: Name -> Q Exp
makeShowbList :: Name -> Q Exp
makeShowbList name :: Name
name = [| showbListWith $(makeShowb name) |]
makePrintT :: Name -> Q Exp
makePrintT :: Name -> Q Exp
makePrintT name :: Name
name = [| TS.putStrLn . $(makeShowt name) |]
makePrintTL :: Name -> Q Exp
makePrintTL :: Name -> Q Exp
makePrintTL name :: Name
name = [| TL.putStrLn . $(makeShowtl name) |]
makeHPrintT :: Name -> Q Exp
makeHPrintT :: Name -> Q Exp
makeHPrintT name :: Name
name = [| \h -> TS.hPutStrLn h . $(makeShowt name) |]
makeHPrintTL :: Name -> Q Exp
makeHPrintTL :: Name -> Q Exp
makeHPrintTL name :: Name
name = [| \h -> TL.hPutStrLn h . $(makeShowtl name) |]
deriveTextShowClass :: TextShowClass -> Options -> Name -> Q [Dec]
deriveTextShowClass :: TextShowClass -> Options -> Name -> Q [Dec]
deriveTextShowClass tsClass :: TextShowClass
tsClass opts :: Options
opts name :: Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
case DatatypeInfo
info of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTys
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} -> do
(instanceCxt :: Cxt
instanceCxt, instanceType :: Type
instanceType)
<- TextShowClass
-> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance TextShowClass
tsClass Name
parentName Cxt
ctxt Cxt
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
<$> CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD (Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
(Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
(TextShowClass -> Options -> Cxt -> [ConstructorInfo] -> [Q Dec]
showbPrecDecs TextShowClass
tsClass Options
opts Cxt
instTys [ConstructorInfo]
cons)
showbPrecDecs :: TextShowClass -> Options -> [Type] -> [ConstructorInfo] -> [Q Dec]
showbPrecDecs :: TextShowClass -> Options -> Cxt -> [ConstructorInfo] -> [Q Dec]
showbPrecDecs tsClass :: TextShowClass
tsClass opts :: Options
opts instTys :: Cxt
instTys cons :: [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
AlwaysTextMethods -> Bool
True
SometimesTextMethods -> (ConstructorInfo -> Bool) -> [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConstructorInfo -> Bool
isNullaryCon [ConstructorInfo]
cons
NeverTextMethods -> Bool
False
genMethod :: TextShowFun -> Name -> Q Dec
genMethod :: TextShowFun -> Name -> Q Dec
genMethod method :: TextShowFun
method methodName :: Name
methodName
= Name -> [ClauseQ] -> Q Dec
funD Name
methodName
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ TextShowClass
-> TextShowFun -> Options -> Cxt -> [ConstructorInfo] -> Q Exp
makeTextShowForCons TextShowClass
tsClass TextShowFun
method Options
opts Cxt
instTys [ConstructorInfo]
cons)
[]
]
makeShowbPrecClass :: TextShowClass -> TextShowFun -> Options -> Name -> Q Exp
makeShowbPrecClass :: TextShowClass -> TextShowFun -> Options -> Name -> Q Exp
makeShowbPrecClass tsClass :: TextShowClass
tsClass tsFun :: TextShowFun
tsFun opts :: Options
opts name :: Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
case DatatypeInfo
info of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTys
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} ->
TextShowClass
-> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance TextShowClass
tsClass Name
parentName Cxt
ctxt Cxt
instTys DatatypeVariant
variant
Q (Cxt, Type) -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextShowClass
-> TextShowFun -> Options -> Cxt -> [ConstructorInfo] -> Q Exp
makeTextShowForCons TextShowClass
tsClass TextShowFun
tsFun Options
opts Cxt
instTys [ConstructorInfo]
cons
makeTextShowForCons :: TextShowClass -> TextShowFun -> Options -> [Type] -> [ConstructorInfo]
-> Q Exp
makeTextShowForCons :: TextShowClass
-> TextShowFun -> Options -> Cxt -> [ConstructorInfo] -> Q Exp
makeTextShowForCons tsClass :: TextShowClass
tsClass tsFun :: TextShowFun
tsFun opts :: Options
opts instTys :: Cxt
instTys cons :: [ConstructorInfo]
cons = do
Name
p <- String -> Q Name
newName "p"
Name
value <- String -> Q Name
newName "value"
[Name]
sps <- String -> Int -> Q [Name]
newNameList "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 "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) -> Cxt -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName (Cxt -> [Name]) -> Cxt -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
drop (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
instTys Int -> Int -> Int
forall a. Num a => a -> a -> a
- TextShowClass -> Int
forall a. Enum a => a -> Int
fromEnum TextShowClass
tsClass) Cxt
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 (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons Bool -> Bool -> Bool
&& Options -> Bool
emptyCaseBehavior Options
opts Bool -> Bool -> Bool
&& Bool
ghc7'8OrLater
= Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
value) []
| [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons
= Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'seq) (Name -> Q Exp
varE Name
value) Q Exp -> Q Exp -> Q Exp
`appE`
Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'error)
(String -> Q Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "Void " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase (TextShowClass -> TextShowFun -> Name
showPrecName TextShowClass
tsClass TextShowFun
tsFun))
| Bool
otherwise
= Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
value)
((ConstructorInfo -> MatchQ) -> [ConstructorInfo] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name
-> TextShowClass
-> TextShowFun
-> Map Name (Name, Name)
-> ConstructorInfo
-> MatchQ
makeTextShowForCon Name
p TextShowClass
tsClass TextShowFun
tsFun Map Name (Name, Name)
splMap) [ConstructorInfo]
cons)
[PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP ([Name] -> [PatQ]) -> [Name] -> [PatQ]
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
appsE
([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q 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
varE [Name]
spsAndSls
[Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ [Name -> Q Exp
varE Name
p, Name -> Q Exp
varE Name
value]
where
ghc7'8OrLater :: Bool
#if __GLASGOW_HASKELL__ >= 708
ghc7'8OrLater :: Bool
ghc7'8OrLater = Bool
True
#else
ghc7'8OrLater = False
#endif
makeTextShowForCon :: Name
-> TextShowClass
-> TextShowFun
-> TyVarMap
-> ConstructorInfo
-> Q Match
makeTextShowForCon :: Name
-> TextShowClass
-> TextShowFun
-> Map Name (Name, Name)
-> ConstructorInfo
-> MatchQ
makeTextShowForCon _ _ tsFun :: TextShowFun
tsFun _
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName, constructorFields :: ConstructorInfo -> Cxt
constructorFields = [] }) =
PatQ -> BodyQ -> [Q Dec] -> MatchQ
match
(Name -> [PatQ] -> PatQ
conP Name
conName [])
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE (TextShowFun -> Name
fromStringName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE (Name -> String -> String
parenInfixConName Name
conName ""))
[]
makeTextShowForCon p :: Name
p tsClass :: TextShowClass
tsClass tsFun :: TextShowFun
tsFun tvMap :: Map Name (Name, Name)
tvMap
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = [argTy :: Type
argTy] }) = do
Type
argTy' <- Type -> TypeQ
resolveTypeSynonyms Type
argTy
Name
arg <- String -> Q Name
newName "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
infixApp (Name -> Q Exp
varE (TextShowFun -> Name
fromStringName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE (Name -> String -> String
parenInfixConName Name
conName " "))
[| (<>) |]
Q Exp
showArg
PatQ -> BodyQ -> [Q Dec] -> MatchQ
match
(Name -> [PatQ] -> PatQ
conP Name
conName [Name -> PatQ
varP Name
arg])
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE (TextShowFun -> Name
showParenName TextShowFun
tsFun)
Q Exp -> Q Exp -> Q Exp
`appE` Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
p) [| (>) |] (Int -> Q Exp
integerE Int
appPrec)
Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
namedArg)
[]
makeTextShowForCon p :: Name
p tsClass :: TextShowClass
tsClass tsFun :: TextShowFun
tsFun tvMap :: Map Name (Name, Name)
tvMap
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
argTys }) = do
Cxt
argTys' <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
argTys
[Name]
args <- String -> Int -> Q [Name]
newNameList "arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
argTys'
if Name -> Bool
isNonUnitTuple Name
conName
then do
let showArgs :: [Q Exp]
showArgs = (Type -> Name -> Q Exp) -> Cxt -> [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 0 TextShowClass
tsClass TextShowFun
tsFun Name
conName Map Name (Name, Name)
tvMap) Cxt
argTys' [Name]
args
parenCommaArgs :: [Q Exp]
parenCommaArgs = (Name -> Q Exp
varE (TextShowFun -> Name
singletonName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
`appE` Char -> Q Exp
charE '(')
Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
intersperse (Name -> Q Exp
varE (TextShowFun -> Name
singletonName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
`appE` Char -> Q Exp
charE ',') [Q Exp]
showArgs
mappendArgs :: Q Exp
mappendArgs = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' (Q Exp -> Q Exp -> Q Exp -> Q Exp
`infixApp` [| (<>) |])
(Name -> Q Exp
varE (TextShowFun -> Name
singletonName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
`appE` Char -> Q Exp
charE ')')
[Q Exp]
parenCommaArgs
PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args)
(Q Exp -> BodyQ
normalB Q Exp
mappendArgs)
[]
else do
let showArgs :: [Q Exp]
showArgs = (Type -> Name -> Q Exp) -> Cxt -> [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) Cxt
argTys' [Name]
args
mappendArgs :: Q Exp
mappendArgs = (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\v :: Q Exp
v q :: Q Exp
q -> Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp Q Exp
v
[| (<>) |]
(Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q 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
infixApp (Name -> Q Exp
varE (TextShowFun -> Name
fromStringName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE (Name -> String -> String
parenInfixConName Name
conName " "))
[| (<>) |]
Q Exp
mappendArgs
PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args)
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE (TextShowFun -> Name
showParenName TextShowFun
tsFun)
Q Exp -> Q Exp -> Q Exp
`appE` Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
p) [| (>) |] (Int -> Q Exp
integerE Int
appPrec)
Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
namedArgs)
[]
makeTextShowForCon p :: Name
p tsClass :: TextShowClass
tsClass tsFun :: TextShowFun
tsFun tvMap :: Map Name (Name, Name)
tvMap
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = RecordConstructor argNames :: [Name]
argNames
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
argTys }) = do
Cxt
argTys' <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
argTys
[Name]
args <- String -> Int -> Q [Name]
newNameList "arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
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 (\(argName :: Name
argName, argTy :: Type
argTy, arg :: 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) ""
in [ Name -> Q Exp
varE (TextShowFun -> Name
fromStringName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE (String
infixRec String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = ")
, Int
-> TextShowClass
-> TextShowFun
-> Name
-> Map Name (Name, Name)
-> Type
-> Name
-> Q Exp
makeTextShowForArg 0 TextShowClass
tsClass TextShowFun
tsFun Name
conName Map Name (Name, Name)
tvMap Type
argTy Name
arg
, Name -> Q Exp
varE (TextShowFun -> Name
showCommaSpaceName TextShowFun
tsFun)
]
)
([Name] -> Cxt -> [Name] -> [(Name, Type, Name)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
argNames Cxt
argTys' [Name]
args)
braceCommaArgs :: [Q Exp]
braceCommaArgs = (Name -> Q Exp
varE (TextShowFun -> Name
singletonName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
`appE` Char -> Q Exp
charE '{') 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 (t :: * -> *) a. Foldable t => t a -> Int
length [Q Exp]
showArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) [Q Exp]
showArgs
mappendArgs :: Q Exp
mappendArgs = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' (Q Exp -> Q Exp -> Q Exp -> Q Exp
`infixApp` [| (<>) |])
(Name -> Q Exp
varE (TextShowFun -> Name
singletonName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
`appE` Char -> Q Exp
charE '}')
[Q Exp]
braceCommaArgs
namedArgs :: Q Exp
namedArgs = Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE (TextShowFun -> Name
fromStringName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE (Name -> String -> String
parenInfixConName Name
conName " "))
[| (<>) |]
Q Exp
mappendArgs
PatQ -> BodyQ -> [Q Dec] -> MatchQ
match
(Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args)
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE (TextShowFun -> Name
showParenName TextShowFun
tsFun)
Q Exp -> Q Exp -> Q Exp
`appE` Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
p) [| (>) |] (Int -> Q Exp
integerE Int
appPrec)
Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
namedArgs)
[]
makeTextShowForCon p :: Name
p tsClass :: TextShowClass
tsClass tsFun :: TextShowFun
tsFun tvMap :: Map Name (Name, Name)
tvMap
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
conName
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
InfixConstructor
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
argTys }) = do
[alTy :: Type
alTy, arTy :: Type
arTy] <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
argTys
Name
al <- String -> Q Name
newName "argL"
Name
ar <- String -> Q Name
newName "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 prec :: Int
prec _ -> Int
prec
opName :: String
opName = Name -> String
nameBase Name
conName
infixOpE :: Q Exp
infixOpE = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q 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
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$
if String -> Bool
isInfixDataCon String
opName
then " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
opName String -> String -> String
forall a. [a] -> [a] -> [a]
++ " "
else " `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
opName String -> String -> String
forall a. [a] -> [a] -> [a]
++ "` "
PatQ -> BodyQ -> [Q Dec] -> MatchQ
match
(PatQ -> Name -> PatQ -> PatQ
infixP (Name -> PatQ
varP Name
al) Name
conName (Name -> PatQ
varP Name
ar))
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ (Name -> Q Exp
varE (TextShowFun -> Name
showParenName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
`appE` Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
p) [| (>) |] (Int -> Q Exp
integerE Int
conPrec))
Q Exp -> Q Exp -> Q Exp
`appE` (Q Exp -> Q Exp -> Q Exp -> Q 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
+ 1) TextShowClass
tsClass TextShowFun
tsFun Name
conName Map Name (Name, Name)
tvMap Type
alTy Name
al)
[| (<>) |]
(Q Exp -> Q Exp -> Q Exp -> Q 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
+ 1) TextShowClass
tsClass TextShowFun
tsFun Name
conName Map Name (Name, Name)
tvMap Type
arTy Name
ar)))
)
[]
makeTextShowForArg :: Int
-> TextShowClass
-> TextShowFun
-> Name
-> TyVarMap
-> Type
-> Name
-> Q Exp
makeTextShowForArg :: Int
-> TextShowClass
-> TextShowFun
-> Name
-> Map Name (Name, Name)
-> Type
-> Name
-> Q Exp
makeTextShowForArg p :: Int
p _ tsFun :: TextShowFun
tsFun _ _ (ConT tyName :: Name
tyName) tyExpName :: Name
tyExpName =
Q Exp
showE
where
tyVarE, showPrecE :: Q Exp
tyVarE :: Q Exp
tyVarE = Name -> Q Exp
varE Name
tyExpName
showPrecE :: Q Exp
showPrecE = Name -> Q 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 ps :: PrimShow
ps -> PrimShow -> Q Exp
showPrimE PrimShow
ps
Nothing -> Q Exp
showPrecE Q Exp -> Q Exp -> Q Exp
`appE` Int -> Q Exp
integerE Int
p Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
tyVarE
showPrimE :: PrimShow -> Q Exp
showPrimE :: PrimShow -> Q Exp
showPrimE PrimShow{ Q Exp -> Q Exp
primShowBoxer :: PrimShow -> Q Exp -> Q Exp
primShowBoxer :: Q Exp -> Q Exp
primShowBoxer
#if __GLASGOW_HASKELL__ >= 800
, TextShowFun -> Q Exp
primShowPostfixMod :: PrimShow -> TextShowFun -> Q Exp
primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod, TextShowFun -> Q Exp -> Q Exp
primShowConv :: PrimShow -> TextShowFun -> Q Exp -> Q Exp
primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv
#endif
}
#if __GLASGOW_HASKELL__ >= 800
= 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
infixApp (Int -> Q Exp
primE 0) [| (<>) |] (TextShowFun -> Q Exp
primShowPostfixMod TextShowFun
tsFun)
#else
= primE p
#endif
where
primE :: Int -> Q Exp
primE :: Int -> Q Exp
primE prec :: Int
prec = Q Exp
showPrecE Q Exp -> Q Exp -> Q Exp
`appE` Int -> Q Exp
integerE Int
prec Q Exp -> Q Exp -> Q Exp
`appE` Q Exp -> Q Exp
primShowBoxer Q Exp
tyVarE
makeTextShowForArg p :: Int
p tsClass :: TextShowClass
tsClass tsFun :: TextShowFun
tsFun conName :: Name
conName tvMap :: Map Name (Name, Name)
tvMap ty :: Type
ty tyExpName :: Name
tyExpName =
[| $(makeTextShowForType tsClass tsFun conName tvMap False ty) p $(varE tyExpName) |]
makeTextShowForType :: TextShowClass
-> TextShowFun
-> Name
-> TyVarMap
-> Bool
-> Type
-> Q Exp
makeTextShowForType :: TextShowClass
-> TextShowFun
-> Name
-> Map Name (Name, Name)
-> Bool
-> Type
-> Q Exp
makeTextShowForType _ tsFun :: TextShowFun
tsFun _ tvMap :: Map Name (Name, Name)
tvMap sl :: Bool
sl (VarT tyName :: Name
tyName) =
Name -> Q 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 (spExp :: Name
spExp, slExp :: Name
slExp) -> if Bool
sl then Name
slExp else Name
spExp
Nothing -> if Bool
sl then TextShowClass -> TextShowFun -> Name
showListName TextShowClass
TextShow TextShowFun
tsFun
else TextShowClass -> TextShowFun -> Name
showPrecName TextShowClass
TextShow TextShowFun
tsFun
makeTextShowForType tsClass :: TextShowClass
tsClass tsFun :: TextShowFun
tsFun conName :: Name
conName tvMap :: Map Name (Name, Name)
tvMap sl :: Bool
sl (SigT ty :: 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 tsClass :: TextShowClass
tsClass tsFun :: TextShowFun
tsFun conName :: Name
conName tvMap :: Map Name (Name, Name)
tvMap sl :: Bool
sl (ForallT _ _ ty :: 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 tsClass :: TextShowClass
tsClass tsFun :: TextShowFun
tsFun conName :: Name
conName tvMap :: Map Name (Name, Name)
tvMap sl :: Bool
sl ty :: Type
ty = do
let tyCon :: Type
tyArgs :: [Type]
tyCon :: Type
tyCon :| tyArgs :: Cxt
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) (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs)
lhsArgs, rhsArgs :: [Type]
(lhsArgs :: Cxt
lhsArgs, rhsArgs :: Cxt
rhsArgs) = Int -> Cxt -> (Cxt, Cxt)
forall a. Int -> [a] -> ([a], [a])
splitAt (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) Cxt
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 <- Type -> Q Bool
isTyFamily Type
tyCon
if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
lhsArgs
Bool -> Bool -> Bool
|| Bool
itf Bool -> Bool -> Bool
&& (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
tyArgs
then TextShowClass -> Name -> Q Exp
forall a. TextShowClass -> Name -> a
outOfPlaceTyVarError TextShowClass
tsClass Name
conName
else if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
rhsArgs
then [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q 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] -> Cxt -> [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. [a] -> [a]
cycle [Bool
False,Bool
True])
(Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
interleave Cxt
rhsArgs Cxt
rhsArgs)
else Name -> Q 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
buildTypeInstance :: TextShowClass
-> Name
-> Cxt
-> [Type]
-> DatatypeVariant
-> Q (Cxt, Type)
buildTypeInstance :: TextShowClass
-> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance tsClass :: TextShowClass
tsClass tyConName :: Name
tyConName dataCxt :: Cxt
dataCxt varTysOrig :: Cxt
varTysOrig variant :: DatatypeVariant
variant = do
Cxt
varTysExp <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
varTysOrig
let remainingLength :: Int
remainingLength :: Int
remainingLength = Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
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 :: Cxt
droppedTysExp = Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
drop Int
remainingLength Cxt
varTysExp
droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = (Type -> StarKindStatus) -> Cxt -> [StarKindStatus]
forall a b. (a -> b) -> [a] -> [b]
map Type -> StarKindStatus
canRealizeKindStar Cxt
droppedTysExp
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
remainingLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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 -> a
derivingKindError TextShowClass
tsClass Name
tyConName
let droppedKindVarNames :: [Name]
droppedKindVarNames :: [Name]
droppedKindVarNames = [StarKindStatus] -> [Name]
catKindVarNames [StarKindStatus]
droppedStarKindStati
varTysExpSubst :: [Type]
varTysExpSubst :: Cxt
varTysExpSubst = (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
droppedKindVarNames) Cxt
varTysExp
remainingTysExpSubst, droppedTysExpSubst :: [Type]
(remainingTysExpSubst :: Cxt
remainingTysExpSubst, droppedTysExpSubst :: Cxt
droppedTysExpSubst) =
Int -> Cxt -> (Cxt, Cxt)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength Cxt
varTysExpSubst
droppedTyVarNames :: [Name]
droppedTyVarNames :: [Name]
droppedTyVarNames = Cxt -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Cxt
droppedTysExpSubst
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
hasKindStar Cxt
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
TextShowClass -> Name -> Q ()
forall a. TextShowClass -> Name -> a
derivingKindError TextShowClass
tsClass Name
tyConName
let preds :: [Maybe Pred]
kvNames :: [[Name]]
kvNames' :: [Name]
(preds :: [Maybe Type]
preds, kvNames :: [[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])) -> Cxt -> [(Maybe Type, [Name])]
forall a b. (a -> b) -> [a] -> [b]
map (TextShowClass -> Type -> (Maybe Type, [Name])
deriveConstraint TextShowClass
tsClass) Cxt
remainingTysExpSubst
kvNames' :: [Name]
kvNames' = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Name]]
kvNames
remainingTysExpSubst' :: [Type]
remainingTysExpSubst' :: Cxt
remainingTysExpSubst' =
(Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
kvNames') Cxt
remainingTysExpSubst
remainingTysOrigSubst :: [Type]
remainingTysOrigSubst :: Cxt
remainingTysOrigSubst =
(Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar ([Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
union [Name]
droppedKindVarNames [Name]
kvNames'))
(Cxt -> Cxt) -> Cxt -> Cxt
forall a b. (a -> b) -> a -> b
$ Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
take Int
remainingLength Cxt
varTysOrig
isDataFamily :: Bool
isDataFamily :: Bool
isDataFamily = case DatatypeVariant
variant of
Datatype -> Bool
False
Newtype -> Bool
False
DataInstance -> Bool
True
NewtypeInstance -> Bool
True
remainingTysOrigSubst' :: [Type]
remainingTysOrigSubst' :: Cxt
remainingTysOrigSubst' =
if Bool
isDataFamily
then Cxt
remainingTysOrigSubst
else (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
unSigT Cxt
remainingTysOrigSubst
instanceCxt :: Cxt
instanceCxt :: Cxt
instanceCxt = [Maybe Type] -> Cxt
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 -> Cxt -> Type
applyTyCon Name
tyConName Cxt
remainingTysOrigSubst'
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`predMentionsName` [Name]
droppedTyVarNames) Cxt
dataCxt) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
Name -> Type -> Q ()
forall a. Name -> Type -> a
datatypeContextError Name
tyConName Type
instanceType
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Cxt -> Cxt -> Bool
canEtaReduce Cxt
remainingTysExpSubst' Cxt
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
Type -> Q ()
forall a. Type -> a
etaReductionError Type
instanceType
(Cxt, Type) -> Q (Cxt, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cxt
instanceCxt, Type
instanceType)
deriveConstraint :: TextShowClass -> Type -> (Maybe Pred, [Name])
deriveConstraint :: TextShowClass -> Type -> (Maybe Type, [Name])
deriveConstraint tsClass :: TextShowClass
tsClass t :: 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 1 Type
t of
Just ns :: [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)
_ -> case Int -> Type -> Maybe [Name]
hasKindVarChain 2 Type
t of
Just ns :: [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 Type
forall a. Maybe a
Nothing, [])
where
tName :: Name
tName :: Name
tName = Type -> Name
varTToName Type
t
derivingKindError :: TextShowClass -> Name -> a
derivingKindError :: TextShowClass -> Name -> a
derivingKindError tsClass :: TextShowClass
tsClass tyConName :: Name
tyConName = String -> a
forall a. HasCallStack => String -> a
error
(String -> a) -> (String -> String) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString "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 ' '
(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
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString "‘\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 " 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 -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ ""
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
etaReductionError :: Type -> a
etaReductionError :: Type -> a
etaReductionError instanceType :: Type
instanceType = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
"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
datatypeContextError :: Name -> Type -> a
datatypeContextError :: Name -> Type -> a
datatypeContextError dataName :: Name
dataName instanceType :: Type
instanceType = String -> a
forall a. HasCallStack => String -> a
error
(String -> a) -> (String -> String) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString "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 "‘:\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 "‘ must not have a class context involving the last type argument(s)"
(String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ ""
outOfPlaceTyVarError :: TextShowClass -> Name -> a
outOfPlaceTyVarError :: TextShowClass -> Name -> a
outOfPlaceTyVarError tsClass :: TextShowClass
tsClass conName :: Name
conName = String -> a
forall a. HasCallStack => String -> a
error
(String -> a) -> (String -> String) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString "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 "‘ 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 " 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 " argument(s) of a data type"
(String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ ""
where
n :: Int
n :: Int
n = TextShowClass -> Int
forall a. Enum a => a -> Int
fromEnum TextShowClass
tsClass
applySubstitutionKind :: Map Name Kind -> Type -> Type
#if MIN_VERSION_template_haskell(2,8,0)
applySubstitutionKind :: Map Name Type -> Type -> Type
applySubstitutionKind = Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution
#else
applySubstitutionKind _ t = t
#endif
substNameWithKind :: Name -> Kind -> Type -> Type
substNameWithKind :: Name -> Type -> Type -> Type
substNameWithKind n :: Name
n k :: Type
k = Map Name Type -> Type -> Type
applySubstitutionKind (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 ns :: [Name]
ns t :: Type
t = (Name -> Type -> Type) -> Type -> [Name] -> Type
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
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
enumFromThenTo :: TextShowClass -> TextShowClass -> TextShowClass -> [TextShowClass]
$cenumFromThenTo :: TextShowClass -> TextShowClass -> TextShowClass -> [TextShowClass]
enumFromTo :: TextShowClass -> TextShowClass -> [TextShowClass]
$cenumFromTo :: TextShowClass -> TextShowClass -> [TextShowClass]
enumFromThen :: TextShowClass -> TextShowClass -> [TextShowClass]
$cenumFromThen :: TextShowClass -> TextShowClass -> [TextShowClass]
enumFrom :: TextShowClass -> [TextShowClass]
$cenumFrom :: TextShowClass -> [TextShowClass]
fromEnum :: TextShowClass -> Int
$cfromEnum :: TextShowClass -> Int
toEnum :: Int -> TextShowClass
$ctoEnum :: Int -> TextShowClass
pred :: TextShowClass -> TextShowClass
$cpred :: TextShowClass -> TextShowClass
succ :: TextShowClass -> TextShowClass
$csucc :: TextShowClass -> TextShowClass
Enum, TextShowClass -> TextShowClass -> Bool
(TextShowClass -> TextShowClass -> Bool)
-> (TextShowClass -> TextShowClass -> Bool) -> Eq TextShowClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextShowClass -> TextShowClass -> Bool
$c/= :: TextShowClass -> TextShowClass -> Bool
== :: TextShowClass -> TextShowClass -> Bool
$c== :: 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
min :: TextShowClass -> TextShowClass -> TextShowClass
$cmin :: TextShowClass -> TextShowClass -> TextShowClass
max :: TextShowClass -> TextShowClass -> TextShowClass
$cmax :: TextShowClass -> TextShowClass -> TextShowClass
>= :: TextShowClass -> TextShowClass -> Bool
$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
compare :: TextShowClass -> TextShowClass -> Ordering
$ccompare :: TextShowClass -> TextShowClass -> Ordering
$cp1Ord :: Eq TextShowClass
Ord)
data TextShowFun = ShowbPrec | ShowtPrec | ShowtlPrec
fromStringName :: TextShowFun -> Name
fromStringName :: TextShowFun -> Name
fromStringName ShowbPrec = 'TB.fromString
fromStringName ShowtPrec = 'TS.pack
fromStringName ShowtlPrec = 'TL.pack
singletonName :: TextShowFun -> Name
singletonName :: TextShowFun -> Name
singletonName ShowbPrec = 'TB.singleton
singletonName ShowtPrec = 'TS.singleton
singletonName ShowtlPrec = 'TL.singleton
showParenName :: TextShowFun -> Name
showParenName :: TextShowFun -> Name
showParenName ShowbPrec = 'showbParen
showParenName ShowtPrec = 'showtParen
showParenName ShowtlPrec = 'showtlParen
showCommaSpaceName :: TextShowFun -> Name
showCommaSpaceName :: TextShowFun -> Name
showCommaSpaceName ShowbPrec = 'showbCommaSpace
showCommaSpaceName ShowtPrec = 'showtCommaSpace
showCommaSpaceName ShowtlPrec = 'showtlCommaSpace
showSpaceName :: TextShowFun -> Name
showSpaceName :: TextShowFun -> Name
showSpaceName ShowbPrec = 'showbSpace
showSpaceName ShowtPrec = 'showtSpace
showSpaceName ShowtlPrec = 'showtlSpace
showPrecConstName :: TextShowClass -> TextShowFun -> Name
showPrecConstName :: TextShowClass -> TextShowFun -> Name
showPrecConstName tsClass :: TextShowClass
tsClass ShowbPrec = TextShowClass -> Name
showbPrecConstName TextShowClass
tsClass
showPrecConstName TextShow ShowtPrec = 'showtPrecConst
showPrecConstName TextShow ShowtlPrec = 'showtlPrecConst
showPrecConstName _ _ = String -> Name
forall a. HasCallStack => String -> a
error "showPrecConstName"
showbPrecConstName :: TextShowClass -> Name
showbPrecConstName :: TextShowClass -> Name
showbPrecConstName TextShow = 'showbPrecConst
showbPrecConstName TextShow1 = 'liftShowbPrecConst
showbPrecConstName TextShow2 = 'liftShowbPrec2Const
textShowClassName :: TextShowClass -> Name
textShowClassName :: TextShowClass -> Name
textShowClassName TextShow = ''TextShow
textShowClassName TextShow1 = ''TextShow1
textShowClassName TextShow2 = ''TextShow2
showPrecName :: TextShowClass -> TextShowFun -> Name
showPrecName :: TextShowClass -> TextShowFun -> Name
showPrecName tsClass :: TextShowClass
tsClass ShowbPrec = TextShowClass -> Name
showbPrecName TextShowClass
tsClass
showPrecName TextShow ShowtPrec = 'showtPrec
showPrecName TextShow ShowtlPrec = 'showtlPrec
showPrecName _ _ = String -> Name
forall a. HasCallStack => String -> a
error "showPrecName"
showbPrecName :: TextShowClass -> Name
showbPrecName :: TextShowClass -> Name
showbPrecName TextShow = 'showbPrec
showbPrecName TextShow1 = 'liftShowbPrec
showbPrecName TextShow2 = 'liftShowbPrec2
showListName :: TextShowClass -> TextShowFun -> Name
showListName :: TextShowClass -> TextShowFun -> Name
showListName tsClass :: TextShowClass
tsClass ShowbPrec = TextShowClass -> Name
showbListName TextShowClass
tsClass
showListName TextShow ShowtPrec = 'showtPrec
showListName TextShow ShowtlPrec = 'showtlPrec
showListName _ _ = String -> Name
forall a. HasCallStack => String -> a
error "showListName"
showbListName :: TextShowClass -> Name
showbListName :: TextShowClass -> Name
showbListName TextShow = 'showbList
showbListName TextShow1 = 'liftShowbList
showbListName TextShow2 = 'liftShowbList2
showPrecOrListName :: Bool
-> TextShowClass
-> TextShowFun
-> Name
showPrecOrListName :: Bool -> TextShowClass -> TextShowFun -> Name
showPrecOrListName False = TextShowClass -> TextShowFun -> Name
showPrecName
showPrecOrListName True = TextShowClass -> TextShowFun -> Name
showListName
showbPrecConst :: Builder
-> Int -> a -> Builder
showbPrecConst :: Builder -> Int -> a -> Builder
showbPrecConst b :: Builder
b _ _ = Builder
b
showtPrecConst :: TS.Text
-> Int -> a -> TS.Text
showtPrecConst :: Text -> Int -> a -> Text
showtPrecConst t :: Text
t _ _ = Text
t
showtlPrecConst :: TL.Text
-> Int -> a -> TL.Text
showtlPrecConst :: Text -> Int -> a -> Text
showtlPrecConst tl :: Text
tl _ _ = Text
tl
liftShowbPrecConst :: Builder
-> (Int -> a -> Builder) -> ([a] -> Builder)
-> Int -> f a -> Builder
liftShowbPrecConst :: Builder
-> (Int -> a -> Builder)
-> ([a] -> Builder)
-> Int
-> f a
-> Builder
liftShowbPrecConst b :: Builder
b _ _ _ _ = Builder
b
liftShowbPrec2Const :: Builder
-> (Int -> a -> Builder) -> ([a] -> Builder)
-> (Int -> b -> Builder) -> ([b] -> Builder)
-> Int -> f a b -> Builder
liftShowbPrec2Const :: Builder
-> (Int -> a -> Builder)
-> ([a] -> Builder)
-> (Int -> b -> Builder)
-> ([b] -> Builder)
-> Int
-> f a b
-> Builder
liftShowbPrec2Const b :: Builder
b _ _ _ _ _ _ = Builder
b
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
/= :: StarKindStatus -> StarKindStatus -> Bool
$c/= :: StarKindStatus -> StarKindStatus -> Bool
== :: StarKindStatus -> StarKindStatus -> Bool
$c== :: StarKindStatus -> StarKindStatus -> Bool
Eq
canRealizeKindStar :: Type -> StarKindStatus
canRealizeKindStar :: Type -> StarKindStatus
canRealizeKindStar t :: Type
t
| Type -> Bool
hasKindStar Type
t = StarKindStatus
KindStar
| Bool
otherwise = case Type
t of
#if MIN_VERSION_template_haskell(2,8,0)
SigT _ (VarT k :: Name
k) -> Name -> StarKindStatus
IsKindVar Name
k
#endif
_ -> StarKindStatus
NotKindStar
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName (IsKindVar n :: Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
starKindStatusToName _ = Maybe Name
forall a. Maybe a
Nothing
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
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 :: (Q Exp -> Q Exp)
-> (TextShowFun -> Q Exp)
-> (TextShowFun -> Q Exp -> Q Exp)
-> PrimShow
PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
conE 'C#)
, primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
oneHashE
, primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv = \_ x :: Q Exp
x -> Q Exp
x
})
, (''Double#, PrimShow :: (Q Exp -> Q Exp)
-> (TextShowFun -> Q Exp)
-> (TextShowFun -> Q Exp -> Q Exp)
-> PrimShow
PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
conE 'D#)
, primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
twoHashE
, primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv = \_ x :: Q Exp
x -> Q Exp
x
})
, (''Float#, PrimShow :: (Q Exp -> Q Exp)
-> (TextShowFun -> Q Exp)
-> (TextShowFun -> Q Exp -> Q Exp)
-> PrimShow
PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
conE 'F#)
, primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
oneHashE
, primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv = \_ x :: Q Exp
x -> Q Exp
x
})
, (''Int#, PrimShow :: (Q Exp -> Q Exp)
-> (TextShowFun -> Q Exp)
-> (TextShowFun -> Q Exp -> Q Exp)
-> PrimShow
PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
conE 'I#)
, primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
oneHashE
, primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv = \_ x :: Q Exp
x -> Q Exp
x
})
, (''Word#, PrimShow :: (Q Exp -> Q Exp)
-> (TextShowFun -> Q Exp)
-> (TextShowFun -> Q Exp -> Q Exp)
-> PrimShow
PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
conE 'W#)
, primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
twoHashE
, primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv = \_ x :: Q Exp
x -> Q Exp
x
})
#if MIN_VERSION_base(4,13,0)
, (''Int8#, PrimShow :: (Q Exp -> Q Exp)
-> (TextShowFun -> Q Exp)
-> (TextShowFun -> Q Exp -> Q Exp)
-> PrimShow
PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q 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
appE (Name -> Q Exp
varE 'extendInt8#)
, primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
oneHashE
, primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv = String -> TextShowFun -> Q Exp -> Q Exp
mkNarrowE "narrowInt8#"
})
, (''Int16#, PrimShow :: (Q Exp -> Q Exp)
-> (TextShowFun -> Q Exp)
-> (TextShowFun -> Q Exp -> Q Exp)
-> PrimShow
PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q 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
appE (Name -> Q Exp
varE 'extendInt16#)
, primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
oneHashE
, primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv = String -> TextShowFun -> Q Exp -> Q Exp
mkNarrowE "narrowInt16#"
})
, (''Word8#, PrimShow :: (Q Exp -> Q Exp)
-> (TextShowFun -> Q Exp)
-> (TextShowFun -> Q Exp -> Q Exp)
-> PrimShow
PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q 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
appE (Name -> Q Exp
varE 'extendWord8#)
, primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
twoHashE
, primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv = String -> TextShowFun -> Q Exp -> Q Exp
mkNarrowE "narrowWord8#"
})
, (''Word16#, PrimShow :: (Q Exp -> Q Exp)
-> (TextShowFun -> Q Exp)
-> (TextShowFun -> Q Exp -> Q Exp)
-> PrimShow
PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
primShowBoxer = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q 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
appE (Name -> Q Exp
varE 'extendWord16#)
, primShowPostfixMod :: TextShowFun -> Q Exp
primShowPostfixMod = TextShowFun -> Q Exp
twoHashE
, primShowConv :: TextShowFun -> Q Exp -> Q Exp
primShowConv = String -> TextShowFun -> Q Exp -> Q Exp
mkNarrowE "narrowWord16#"
})
#endif
]
#if MIN_VERSION_base(4,13,0)
mkNarrowE :: String -> TextShowFun -> Q Exp -> Q Exp
mkNarrowE :: String -> TextShowFun -> Q Exp -> Q Exp
mkNarrowE narrowStr :: String
narrowStr tsFun :: TextShowFun
tsFun e :: Q Exp
e =
(Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Q Exp -> Q Exp -> Q Exp -> Q Exp
`infixApp` [| (<>) |])
(Name -> Q Exp
varE (TextShowFun -> Name
singletonName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
`appE` Char -> Q Exp
charE ')')
[ Name -> Q Exp
varE (TextShowFun -> Name
fromStringName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE ('('Char -> String -> String
forall a. a -> [a] -> [a]
:String
narrowStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ " ")
, Q Exp
e
]
#endif
oneHashE, twoHashE :: TextShowFun -> Q Exp
oneHashE :: TextShowFun -> Q Exp
oneHashE tsFun :: TextShowFun
tsFun = Name -> Q Exp
varE (TextShowFun -> Name
singletonName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
`appE` Char -> Q Exp
charE '#'
twoHashE :: TextShowFun -> Q Exp
twoHashE tsFun :: TextShowFun
tsFun = Name -> Q Exp
varE (TextShowFun -> Name
fromStringName TextShowFun
tsFun) Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE "##"
integerE :: Int -> Q Exp
integerE :: Int -> Q Exp
integerE = Lit -> Q 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
litE (Lit -> Q Exp) -> (Char -> Lit) -> Char -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Lit
charL
hasKindStar :: Type -> Bool
hasKindStar :: Type -> Bool
hasKindStar VarT{} = Bool
True
#if MIN_VERSION_template_haskell(2,8,0)
hasKindStar (SigT _ StarT) = Bool
True
#else
hasKindStar (SigT _ StarK) = True
#endif
hasKindStar _ = Bool
False
isStarOrVar :: Kind -> Bool
#if MIN_VERSION_template_haskell(2,8,0)
isStarOrVar :: Type -> Bool
isStarOrVar StarT = Bool
True
isStarOrVar VarT{} = Bool
True
#else
isStarOrVar StarK = True
#endif
isStarOrVar _ = Bool
False
newNameList :: String -> Int -> Q [Name]
newNameList :: String -> Int -> Q [Name]
newNameList prefix :: String
prefix n :: 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)
mapM (String -> Q 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) [1..Int
n]
hasKindVarChain :: Int -> Type -> Maybe [Name]
hasKindVarChain :: Int -> Type -> Maybe [Name]
hasKindVarChain kindArrows :: Int
kindArrows t :: Type
t =
let uk :: NonEmpty Type
uk = Type -> NonEmpty Type
uncurryKind (Type -> Type
tyKind Type
t)
in if (NonEmpty Type -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty Type
uk Int -> Int -> Int
forall a. Num a => a -> a -> a
- 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
tyKind :: Type -> Kind
tyKind :: Type -> Type
tyKind (SigT _ k :: Type
k) = Type
k
tyKind _ = Type
starK
type TyVarMap = Map Name (Name, Name)
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
parenInfixConName :: Name -> ShowS
parenInfixConName :: Name -> String -> String
parenInfixConName conName :: 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
applyClass :: Name -> Name -> Pred
#if MIN_VERSION_template_haskell(2,10,0)
applyClass :: Name -> Name -> Type
applyClass con :: Name
con t :: 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
canEtaReduce :: [Type] -> [Type] -> Bool
canEtaReduce :: Cxt -> Cxt -> Bool
canEtaReduce remaining :: Cxt
remaining dropped :: Cxt
dropped =
(Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isTyVar Cxt
dropped
Bool -> Bool -> Bool
&& [Name] -> Bool
forall a. Ord a => [a] -> Bool
allDistinct [Name]
droppedNames
Bool -> Bool -> Bool
&& Bool -> Bool
not ((Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
droppedNames) Cxt
remaining)
where
droppedNames :: [Name]
droppedNames :: [Name]
droppedNames = (Type -> Name) -> Cxt -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName Cxt
dropped
varTToName_maybe :: Type -> Maybe Name
varTToName_maybe :: Type -> Maybe Name
varTToName_maybe (VarT n :: Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
varTToName_maybe (SigT t :: Type
t _) = Type -> Maybe Name
varTToName_maybe Type
t
varTToName_maybe _ = Maybe Name
forall a. Maybe a
Nothing
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 "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
unSigT :: Type -> Type
unSigT :: Type -> Type
unSigT (SigT t :: Type
t _) = Type
t
unSigT t :: Type
t = Type
t
isTyVar :: Type -> Bool
isTyVar :: Type -> Bool
isTyVar (VarT _) = Bool
True
isTyVar (SigT t :: Type
t _) = Type -> Bool
isTyVar Type
t
isTyVar _ = Bool
False
isTyFamily :: Type -> Q Bool
isTyFamily :: Type -> Q Bool
isTyFamily (ConT n :: Name
n) = do
Info
info <- Name -> Q Info
reify Name
n
Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Q Bool) -> Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ case Info
info of
#if MIN_VERSION_template_haskell(2,11,0)
FamilyI OpenTypeFamilyD{} _ -> Bool
True
#else
FamilyI (FamilyD TypeFam _ _ _) _ -> True
#endif
#if MIN_VERSION_template_haskell(2,9,0)
FamilyI ClosedTypeFamilyD{} _ -> Bool
True
#endif
_ -> Bool
False
isTyFamily _ = Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
allDistinct :: Ord a => [a] -> Bool
allDistinct :: [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' :: Set a -> [a] -> Bool
allDistinct' uniqs :: Set a
uniqs (x :: a
x:xs :: [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' _ _ = Bool
True
mentionsName :: Type -> [Name] -> Bool
mentionsName :: Type -> [Name] -> Bool
mentionsName = Type -> [Name] -> Bool
go
where
go :: Type -> [Name] -> Bool
go :: Type -> [Name] -> Bool
go (AppT t1 :: Type
t1 t2 :: Type
t2) names :: [Name]
names = Type -> [Name] -> Bool
go Type
t1 [Name]
names Bool -> Bool -> Bool
|| Type -> [Name] -> Bool
go Type
t2 [Name]
names
go (SigT t :: Type
t _k :: Type
_k) names :: [Name]
names = Type -> [Name] -> Bool
go Type
t [Name]
names
#if MIN_VERSION_template_haskell(2,8,0)
Bool -> Bool -> Bool
|| Type -> [Name] -> Bool
go Type
_k [Name]
names
#endif
go (VarT n :: Name
n) names :: [Name]
names = Name
n Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
names
go _ _ = Bool
False
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
applyTy :: Type -> [Type] -> Type
applyTy :: Type -> Cxt -> Type
applyTy = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT
applyTyCon :: Name -> [Type] -> Type
applyTyCon :: Name -> Cxt -> Type
applyTyCon = Type -> Cxt -> Type
applyTy (Type -> Cxt -> Type) -> (Name -> Type) -> Name -> Cxt -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
ConT
unapplyTy :: Type -> NonEmpty Type
unapplyTy :: Type -> NonEmpty Type
unapplyTy = NonEmpty Type -> NonEmpty Type
forall a. NonEmpty a -> NonEmpty a
NE.reverse (NonEmpty Type -> NonEmpty Type)
-> (Type -> NonEmpty Type) -> Type -> NonEmpty Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> NonEmpty Type
go
where
go :: Type -> NonEmpty Type
go :: Type -> NonEmpty Type
go (AppT t1 :: Type
t1 t2 :: Type
t2) = Type
t2 Type -> NonEmpty Type -> NonEmpty Type
forall a. a -> NonEmpty a -> NonEmpty a
<| Type -> NonEmpty Type
go Type
t1
go (SigT t :: Type
t _) = Type -> NonEmpty Type
go Type
t
go (ForallT _ _ t :: Type
t) = Type -> NonEmpty Type
go Type
t
go t :: Type
t = Type
t Type -> Cxt -> NonEmpty Type
forall a. a -> [a] -> NonEmpty a
:| []
uncurryTy :: Type -> NonEmpty Type
uncurryTy :: Type -> NonEmpty Type
uncurryTy (AppT (AppT ArrowT t1 :: Type
t1) t2 :: Type
t2) = Type
t1 Type -> NonEmpty Type -> NonEmpty Type
forall a. a -> NonEmpty a -> NonEmpty a
<| Type -> NonEmpty Type
uncurryTy Type
t2
uncurryTy (SigT t :: Type
t _) = Type -> NonEmpty Type
uncurryTy Type
t
uncurryTy (ForallT _ _ t :: Type
t) = Type -> NonEmpty Type
uncurryTy Type
t
uncurryTy t :: Type
t = Type
t Type -> Cxt -> NonEmpty Type
forall a. a -> [a] -> NonEmpty a
:| []
uncurryKind :: Kind -> NonEmpty Kind
#if MIN_VERSION_template_haskell(2,8,0)
uncurryKind :: Type -> NonEmpty Type
uncurryKind = Type -> NonEmpty Type
uncurryTy
#else
uncurryKind (ArrowK k1 k2) = k1 <| uncurryKind k2
uncurryKind k = k :| []
#endif
createKindChain :: Int -> Kind
createKindChain :: Int -> Type
createKindChain = Type -> Int -> Type
go Type
starK
where
go :: Kind -> Int -> Kind
go :: Type -> Int -> Type
go k :: Type
k !Int
0 = Type
k
go k :: 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
- 1)
isNullaryCon :: ConstructorInfo -> Bool
isNullaryCon :: ConstructorInfo -> Bool
isNullaryCon (ConstructorInfo { constructorFields :: ConstructorInfo -> Cxt
constructorFields = [] }) = Bool
True
isNullaryCon _ = Bool
False
interleave :: [a] -> [a] -> [a]
interleave :: [a] -> [a] -> [a]
interleave (a1 :: a
a1:a1s :: [a]
a1s) (a2 :: a
a2:a2s :: [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 _ _ = []