module TextShow.TH.Internal (
deriveTextShow
, deriveTextShow1
, deriveTextShow2
, makeShowt
, makeShowtl
, makeShowtPrec
, makeShowtlPrec
, makeShowtList
, makeShowtlList
, makeShowb
, makeShowbPrec
, makeShowbList
, makePrintT
, makePrintTL
, makeHPrintT
, makeHPrintTL
, makeShowbPrecWith
, makeShowbPrec1
, makeShowbPrecWith2
, makeShowbPrec2
) where
import Data.Function (on)
import Data.List.Compat
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty(..), (<|))
import qualified Data.Map as Map (fromList, lookup)
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Data.Monoid.Compat ((<>))
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 Data.Text.Lazy.Builder (Builder, fromString, singleton, 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(..))
import GHC.Prim (Char#, Double#, Float#, Int#, Word#)
import GHC.Show (appPrec, appPrec1)
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, showbSpace)
import TextShow.Utils (isInfixTypeCon, isTupleString)
deriveTextShow :: Name -> Q [Dec]
deriveTextShow = deriveTextShowClass TextShow
deriveTextShow1 :: Name -> Q [Dec]
deriveTextShow1 = deriveTextShowClass TextShow1
deriveTextShow2 :: Name -> Q [Dec]
deriveTextShow2 = deriveTextShowClass TextShow2
makeShowt :: Name -> Q Exp
makeShowt name = [| toStrict . $(makeShowtl name) |]
makeShowtl :: Name -> Q Exp
makeShowtl name = [| toLazyText . $(makeShowb name) |]
makeShowtPrec :: Name -> Q Exp
makeShowtPrec name = [| \p -> toStrict . $(makeShowtlPrec name) p |]
makeShowtlPrec :: Name -> Q Exp
makeShowtlPrec name = [| \p -> toLazyText . $(makeShowbPrec name) p |]
makeShowtList :: Name -> Q Exp
makeShowtList name = [| toStrict . $(makeShowtlList name) |]
makeShowtlList :: Name -> Q Exp
makeShowtlList name = [| toLazyText . $(makeShowbList name) |]
makeShowb :: Name -> Q Exp
makeShowb name = makeShowbPrec name `appE` [| zero |]
where
zero :: Int
zero = 0
makeShowbPrec :: Name -> Q Exp
makeShowbPrec = makeShowbPrecClass TextShow
makeShowbPrecWith :: Name -> Q Exp
makeShowbPrecWith = makeShowbPrecClass TextShow1
makeShowbPrec1 :: Name -> Q Exp
makeShowbPrec1 name = [| $(makeShowbPrecWith name) showbPrec |]
makeShowbPrecWith2 :: Name -> Q Exp
makeShowbPrecWith2 = makeShowbPrecClass TextShow2
makeShowbPrec2 :: Name -> Q Exp
makeShowbPrec2 name = [| $(makeShowbPrecWith2 name) showbPrec showbPrec |]
makeShowbList :: Name -> Q Exp
makeShowbList name = [| showbListWith $(makeShowb name) |]
makePrintT :: Name -> Q Exp
makePrintT name = [| TS.putStrLn . $(makeShowt name) |]
makePrintTL :: Name -> Q Exp
makePrintTL name = [| TL.putStrLn . $(makeShowtl name) |]
makeHPrintT :: Name -> Q Exp
makeHPrintT name = [| \h -> TS.hPutStrLn h . $(makeShowt name) |]
makeHPrintTL :: Name -> Q Exp
makeHPrintTL name = [| \h -> TL.hPutStrLn h . $(makeShowtl name) |]
deriveTextShowClass :: TextShowClass -> Name -> Q [Dec]
deriveTextShowClass tsClass name = withType name fromCons
where
fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec]
fromCons name' ctxt tvbs cons mbTys = (:[]) <$>
instanceD (return instanceCxt)
(return instanceType)
(showbPrecDecs droppedNbs cons)
where
(instanceCxt, instanceType, droppedNbs) =
buildTypeInstance tsClass name' ctxt tvbs mbTys
showbPrecDecs :: [NameBase] -> [Con] -> [Q Dec]
showbPrecDecs nbs cons =
[ funD classFuncName
[ clause []
(normalB $ makeTextShowForCons nbs cons)
[]
]
]
where
classFuncName :: Name
classFuncName = showbPrecName . toEnum $ length nbs
makeShowbPrecClass :: TextShowClass -> Name -> Q Exp
makeShowbPrecClass tsClass name = withType name fromCons
where
fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp
fromCons name' ctxt tvbs cons mbTys =
let (_, _, !nbs) = buildTypeInstance tsClass name' ctxt tvbs mbTys
in makeTextShowForCons nbs cons
makeTextShowForCons :: [NameBase] -> [Con] -> Q Exp
makeTextShowForCons _ [] = error "Must have at least one data constructor"
makeTextShowForCons nbs cons = do
p <- newName "p"
value <- newName "value"
sps <- newNameList "sp" $ length nbs
let tvis = zip nbs sps
tsClass = toEnum $ length nbs
lamE (map varP $ sps ++ [p, value])
. appsE
$ [ varE $ showbPrecConstName tsClass
, caseE (varE value) $ map (makeTextShowForCon p tsClass tvis) cons
] ++ map varE sps
++ [varE p, varE value]
makeTextShowForCon :: Name -> TextShowClass -> [TyVarInfo] -> Con -> Q Match
makeTextShowForCon _ _ _ (NormalC conName [])
= match (conP conName [])
(normalB [| fromString $(stringE (parenInfixConName conName "")) |])
[]
makeTextShowForCon p tsClass tvis (NormalC conName [(_, argTy)]) = do
arg <- newName "arg"
let showArg = makeTextShowForArg appPrec1 tsClass conName tvis argTy arg
namedArg = [| fromString $(stringE (parenInfixConName conName " ")) <> $(showArg) |]
match (conP conName [varP arg])
(normalB [| showbParen ($(varE p) > $(lift appPrec)) $(namedArg) |])
[]
makeTextShowForCon p tsClass tvis (NormalC conName ts) = do
args <- newNameList "arg" $ length ts
if isNonUnitTuple conName
then do
let showArgs = map (\(arg, (_, argTy)) -> makeTextShowForArg 0 tsClass conName tvis argTy arg)
(zip args ts)
parenCommaArgs = [| singleton '(' |] : intersperse [| singleton ',' |] showArgs
mappendArgs = foldr (`infixApp` [| (<>) |])
[| singleton ')' |]
parenCommaArgs
match (conP conName $ map varP args)
(normalB mappendArgs)
[]
else do
let showArgs = map (\(arg, (_, argTy)) -> makeTextShowForArg appPrec1 tsClass conName tvis argTy arg)
(zip args ts)
mappendArgs = foldr1 (\v q -> [| $(v) <> showbSpace <> $(q) |]) showArgs
namedArgs = [| fromString $(stringE (parenInfixConName conName " ")) <> $(mappendArgs) |]
match (conP conName $ map varP args)
(normalB [| showbParen ($(varE p) > $(lift appPrec)) $(namedArgs) |])
[]
makeTextShowForCon p tsClass tvis (RecC conName []) = makeTextShowForCon p tsClass tvis $ NormalC conName []
makeTextShowForCon _p tsClass tvis (RecC conName ts) = do
args <- newNameList "arg" $ length ts
let showArgs = concatMap (\(arg, (argName, _, argTy))
-> [ [| fromString $(stringE (nameBase argName ++ " = ")) |]
, makeTextShowForArg 0 tsClass conName tvis argTy arg
, [| fromString ", " |]
]
)
(zip args ts)
braceCommaArgs = [| singleton '{' |] : take (length showArgs 1) showArgs
mappendArgs = foldr (`infixApp` [| (<>) |])
[| singleton '}' |]
braceCommaArgs
namedArgs = [| fromString $(stringE (parenInfixConName conName " ")) <> $(mappendArgs) |]
match (conP conName $ map varP args)
(normalB
#if __GLASGOW_HASKELL__ >= 711
namedArgs
#else
[| showbParen ($(varE _p) > $(lift appPrec)) $(namedArgs) |]
#endif
)
[]
makeTextShowForCon p tsClass tvis (InfixC (_, alTy) conName (_, arTy)) = do
al <- newName "argL"
ar <- newName "argR"
info <- reify conName
#if __GLASGOW_HASKELL__ >= 711
conPrec <- case info of
DataConI{} -> do
Fixity prec _ <- reifyFixity conName
return prec
#else
let conPrec = case info of
DataConI _ _ _ (Fixity prec _) -> prec
#endif
_ -> error $ "TextShow.TH.makeTextShowForCon: Unsupported type: " ++ show info
let opName = nameBase conName
infixOpE = if isInfixTypeCon opName
then [| fromString $(stringE $ " " ++ opName ++ " " ) |]
else [| fromString $(stringE $ " `" ++ opName ++ "` ") |]
match (infixP (varP al) conName (varP ar))
(normalB $ appE [| showbParen ($(varE p) > conPrec) |]
[| $(makeTextShowForArg (conPrec + 1) tsClass conName tvis alTy al)
<> $(infixOpE)
<> $(makeTextShowForArg (conPrec + 1) tsClass conName tvis arTy ar)
|]
)
[]
makeTextShowForCon p tsClass tvis (ForallC tvbs _ con) = makeTextShowForCon p tsClass (removeForalled tvbs tvis) con
makeTextShowForArg :: Int
-> TextShowClass
-> Name
-> [TyVarInfo]
-> Type
-> Name
-> Q Exp
makeTextShowForArg p tsClass conName tvis ty tyExpName = do
ty' <- expandSyn ty
makeTextShowForArg' p tsClass conName tvis ty' tyExpName
makeTextShowForArg' :: Int
-> TextShowClass
-> Name
-> [TyVarInfo]
-> Type
-> Name
-> Q Exp
makeTextShowForArg' p _ _ _ (ConT tyName) tyExpName =
#if __GLASGOW_HASKELL__ >= 711
showE
where
tyVarE :: Q Exp
tyVarE = varE tyExpName
showE :: Q Exp
showE | tyName == ''Char# = [| showbPrec 0 (C# $(tyVarE)) <> singleton '#' |]
| tyName == ''Double# = [| showbPrec 0 (D# $(tyVarE)) <> fromString "##" |]
| tyName == ''Float# = [| showbPrec 0 (F# $(tyVarE)) <> singleton '#' |]
| tyName == ''Int# = [| showbPrec 0 (I# $(tyVarE)) <> singleton '#' |]
| tyName == ''Word# = [| showbPrec 0 (W# $(tyVarE)) <> fromString "##" |]
| otherwise = [| showbPrec p $(tyVarE) |]
#else
[| showbPrec p $(expr) |]
where
tyVarE :: Q Exp
tyVarE = varE tyExpName
expr :: Q Exp
expr | tyName == ''Char# = [| C# $(tyVarE) |]
| tyName == ''Double# = [| D# $(tyVarE) |]
| tyName == ''Float# = [| F# $(tyVarE) |]
| tyName == ''Int# = [| I# $(tyVarE) |]
| tyName == ''Word# = [| W# $(tyVarE) |]
| otherwise = tyVarE
#endif
makeTextShowForArg' p tsClass conName tvis ty tyExpName =
[| $(makeTextShowForType tsClass conName tvis ty) p $(varE tyExpName) |]
makeTextShowForType :: TextShowClass
-> Name
-> [TyVarInfo]
-> Type
-> Q Exp
makeTextShowForType _ _ tvis (VarT tyName) =
case lookup (NameBase tyName) tvis of
Just spExp -> varE spExp
Nothing -> [| showbPrec |]
makeTextShowForType tsClass conName tvis (SigT ty _) = makeTextShowForType tsClass conName tvis ty
makeTextShowForType tsClass conName tvis (ForallT tvbs _ ty) = makeTextShowForType tsClass conName (removeForalled tvbs tvis) ty
makeTextShowForType tsClass conName tvis ty = do
let tyArgs :: [Type]
tyCon :| tyArgs = unapplyTy ty
numLastArgs :: Int
numLastArgs = min (fromEnum tsClass) (length tyArgs)
lhsArgs, rhsArgs :: [Type]
(lhsArgs, rhsArgs) = splitAt (length tyArgs numLastArgs) tyArgs
tyVarNameBases :: [NameBase]
tyVarNameBases = map fst tvis
itf <- isTyFamily tyCon
if any (`mentionsNameBase` tyVarNameBases) lhsArgs
|| itf && any (`mentionsNameBase` tyVarNameBases) tyArgs
then outOfPlaceTyVarError conName tyVarNameBases
else appsE $ [ varE . showbPrecName $ toEnum numLastArgs]
++ map (makeTextShowForType tsClass conName tvis) rhsArgs
withType :: Name
-> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a)
-> Q a
withType name f = do
info <- reify name
case info of
TyConI dec ->
case dec of
DataD ctxt _ tvbs cons _ -> f name ctxt tvbs cons Nothing
NewtypeD ctxt _ tvbs con _ -> f name ctxt tvbs [con] Nothing
_ -> error $ ns ++ "Unsupported type: " ++ show dec
#if MIN_VERSION_template_haskell(2,7,0)
# if MIN_VERSION_template_haskell(2,11,0)
DataConI _ _ parentName -> do
# else
DataConI _ _ parentName _ -> do
# endif
parentInfo <- reify parentName
case parentInfo of
# if MIN_VERSION_template_haskell(2,11,0)
FamilyI (DataFamilyD _ tvbs _) decs ->
# else
FamilyI (FamilyD DataFam _ tvbs _) decs ->
# endif
let instDec = flip find decs $ \dec -> case dec of
DataInstD _ _ _ cons _ -> any ((name ==) . constructorName) cons
NewtypeInstD _ _ _ con _ -> name == constructorName con
_ -> error $ ns ++ "Must be a data or newtype instance."
in case instDec of
Just (DataInstD ctxt _ instTys cons _)
-> f parentName ctxt tvbs cons $ Just instTys
Just (NewtypeInstD ctxt _ instTys con _)
-> f parentName ctxt tvbs [con] $ Just instTys
_ -> error $ ns ++
"Could not find data or newtype instance constructor."
_ -> error $ ns ++ "Data constructor " ++ show name ++
" is not from a data family instance constructor."
# if MIN_VERSION_template_haskell(2,11,0)
FamilyI DataFamilyD{} _ ->
# else
FamilyI (FamilyD DataFam _ _ _) _ ->
# endif
error $ ns ++
"Cannot use a data family name. Use a data family instance constructor instead."
_ -> error $ ns ++ "The name must be of a plain data type constructor, "
++ "or a data family instance constructor."
#else
DataConI{} -> dataConIError
_ -> error $ ns ++ "The name must be of a plain type constructor."
#endif
where
ns :: String
ns = "TextShow.TH.withType: "
buildTypeInstance :: TextShowClass
-> Name
-> Cxt
-> [TyVarBndr]
-> Maybe [Type]
-> (Cxt, Type, [NameBase])
buildTypeInstance tsClass tyConName dataCxt tvbs Nothing
| remainingLength < 0 || not (wellKinded droppedKinds)
= derivingKindError tsClass tyConName
| any (`predMentionsNameBase` droppedNbs) dataCxt
= datatypeContextError tyConName instanceType
| otherwise = (instanceCxt, instanceType, droppedNbs)
where
instanceCxt :: Cxt
instanceCxt = map (applyShowConstraint)
$ filter (needsConstraint tsClass . tvbKind) remaining
instanceType :: Type
instanceType = AppT (ConT $ textShowClassName tsClass)
. applyTyCon tyConName
$ map (VarT . tvbName) remaining
remainingLength :: Int
remainingLength = length tvbs fromEnum tsClass
remaining, dropped :: [TyVarBndr]
(remaining, dropped) = splitAt remainingLength tvbs
droppedKinds :: [Kind]
droppedKinds = map tvbKind dropped
droppedNbs :: [NameBase]
droppedNbs = map (NameBase . tvbName) dropped
buildTypeInstance tsClass parentName dataCxt tvbs (Just instTysAndKinds)
| remainingLength < 0 || not (wellKinded droppedKinds)
= derivingKindError tsClass parentName
| any (`predMentionsNameBase` droppedNbs) dataCxt
= datatypeContextError parentName instanceType
| canEtaReduce remaining dropped
= (instanceCxt, instanceType, droppedNbs)
| otherwise = etaReductionError instanceType
where
instanceCxt :: Cxt
instanceCxt = map (applyShowConstraint)
$ filter (needsConstraint tsClass . tvbKind) lhsTvbs
instanceType :: Type
instanceType = AppT (ConT $ textShowClassName tsClass)
. applyTyCon parentName
$ map unSigT remaining
remainingLength :: Int
remainingLength = length tvbs fromEnum tsClass
remaining, dropped :: [Type]
(remaining, dropped) = splitAt remainingLength rhsTypes
droppedKinds :: [Kind]
droppedKinds = map tvbKind . snd $ splitAt remainingLength tvbs
droppedNbs :: [NameBase]
droppedNbs = map varTToNameBase dropped
instTypes :: [Type]
instTypes =
#if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0))
instTysAndKinds
#else
drop (Set.size . Set.unions $ map (distinctKindVars . tvbKind) tvbs)
instTysAndKinds
#endif
lhsTvbs :: [TyVarBndr]
lhsTvbs = map (uncurry replaceTyVarName)
. filter (isTyVar . snd)
. take remainingLength
$ zip tvbs rhsTypes
rhsTypes :: [Type]
rhsTypes =
#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710
instTypes ++ map tvbToType
(drop (length instTypes)
tvbs)
#else
instTypes
#endif
applyShowConstraint :: TyVarBndr -> Pred
applyShowConstraint (PlainTV name) = applyClass ''TextShow name
applyShowConstraint (KindedTV name kind) = applyClass className name
where
className :: Name
className = textShowClassName . toEnum $ numKindArrows kind
needsConstraint :: TextShowClass -> Kind -> Bool
needsConstraint tsClass kind =
fromEnum tsClass >= numKindArrows kind
&& canRealizeKindStarChain kind
derivingKindError :: TextShowClass -> Name -> a
derivingKindError tsClass tyConName = error
. showString "Cannot derive well-kinded instance of form ‘"
. showString className
. showChar ' '
. showParen True
( showString (nameBase tyConName)
. showString " ..."
)
. showString "‘\n\tClass "
. showString className
. showString " expects an argument of kind "
. showString (pprint . createKindChain $ fromEnum tsClass)
$ ""
where
className :: String
className = nameBase $ textShowClassName tsClass
etaReductionError :: Type -> a
etaReductionError instanceType = error $
"Cannot eta-reduce to an instance of form \n\tinstance (...) => "
++ pprint instanceType
datatypeContextError :: Name -> Type -> a
datatypeContextError dataName instanceType = error
. showString "Can't make a derived instance of ‘"
. showString (pprint instanceType)
. showString "‘:\n\tData type ‘"
. showString (nameBase dataName)
. showString "‘ must not have a class context involving the last type argument(s)"
$ ""
outOfPlaceTyVarError :: Name -> [NameBase] -> a
outOfPlaceTyVarError conName tyVarNames = error
. showString "Constructor ‘"
. showString (nameBase conName)
. showString "‘ must use the type variable(s) "
. shows tyVarNames
. showString " only in the last argument(s) of a data type"
$ ""
#if !(MIN_VERSION_template_haskell(2,7,0))
dataConIError :: a
dataConIError = error
. showString "Cannot use a data constructor."
. showString "\n\t(Note: if you are trying to derive TextShow for a"
. showString "\n\ttype family, use GHC >= 7.4 instead.)"
$ ""
#endif
expandSyn :: Type -> Q Type
expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t
expandSyn t@AppT{} = expandSynApp t []
expandSyn t@ConT{} = expandSynApp t []
expandSyn (SigT t _) = expandSyn t
expandSyn t = return t
expandSynApp :: Type -> [Type] -> Q Type
expandSynApp (AppT t1 t2) ts = do
t2' <- expandSyn t2
expandSynApp t1 (t2':ts)
expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts
expandSynApp t@(ConT n) ts = do
info <- reify n
case info of
TyConI (TySynD _ tvs rhs) ->
let (ts', ts'') = splitAt (length tvs) ts
subs = mkSubst tvs ts'
rhs' = subst subs rhs
in expandSynApp rhs' ts''
_ -> return $ foldl' AppT t ts
expandSynApp t ts = do
t' <- expandSyn t
return $ foldl' AppT t' ts
type Subst = Map Name Type
mkSubst :: [TyVarBndr] -> [Type] -> Subst
mkSubst vs ts =
let vs' = map un vs
un (PlainTV v) = v
un (KindedTV v _) = v
in Map.fromList $ zip vs' ts
subst :: Subst -> Type -> Type
subst subs (ForallT v c t) = ForallT v c $ subst subs t
subst subs t@(VarT n) = fromMaybe t $ Map.lookup n subs
subst subs (AppT t1 t2) = AppT (subst subs t1) (subst subs t2)
subst subs (SigT t k) = SigT (subst subs t) k
subst _ t = t
data TextShowClass = TextShow | TextShow1 | TextShow2
deriving (Enum, Eq, Ord)
showbPrecConstName :: TextShowClass -> Name
showbPrecConstName TextShow = 'showbPrecConst
showbPrecConstName TextShow1 = 'showbPrecWithConst
showbPrecConstName TextShow2 = 'showbPrecWith2Const
textShowClassName :: TextShowClass -> Name
textShowClassName TextShow = ''TextShow
textShowClassName TextShow1 = ''TextShow1
textShowClassName TextShow2 = ''TextShow2
showbPrecName :: TextShowClass -> Name
showbPrecName TextShow = 'showbPrec
showbPrecName TextShow1 = 'showbPrecWith
showbPrecName TextShow2 = 'showbPrecWith2
showbPrecConst :: Builder -> Int -> a -> Builder
showbPrecConst = const . const
showbPrecWithConst :: Builder -> (Int -> a -> Builder) -> Int -> f a -> Builder
showbPrecWithConst = const . const . const
showbPrecWith2Const :: Builder -> (Int -> a -> Builder) -> (Int -> b -> Builder)
-> Int -> f a b -> Builder
showbPrecWith2Const = const . const . const . const
newtype NameBase = NameBase { getName :: Name }
getNameBase :: NameBase -> String
getNameBase = nameBase . getName
instance Eq NameBase where
(==) = (==) `on` getNameBase
instance Ord NameBase where
compare = compare `on` getNameBase
instance Show NameBase where
showsPrec p = showsPrec p . getNameBase
type TyVarInfo = (NameBase, Name)
newNameList :: String -> Int -> Q [Name]
newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n]
removeForalled :: [TyVarBndr] -> [TyVarInfo] -> [TyVarInfo]
removeForalled tvbs = filter (not . foralled tvbs)
where
foralled :: [TyVarBndr] -> TyVarInfo -> Bool
foralled tvbs' tvi = fst tvi `elem` map (NameBase . tvbName) tvbs'
isNonUnitTuple :: Name -> Bool
isNonUnitTuple = isTupleString . nameBase
parenInfixConName :: Name -> ShowS
parenInfixConName conName =
let conNameBase = nameBase conName
in showParen (isInfixTypeCon conNameBase) $ showString conNameBase
tvbName :: TyVarBndr -> Name
tvbName (PlainTV name) = name
tvbName (KindedTV name _) = name
tvbKind :: TyVarBndr -> Kind
tvbKind (PlainTV _) = starK
tvbKind (KindedTV _ k) = k
replaceTyVarName :: TyVarBndr -> Type -> TyVarBndr
replaceTyVarName tvb (SigT t _) = replaceTyVarName tvb t
replaceTyVarName (PlainTV _) (VarT n) = PlainTV n
replaceTyVarName (KindedTV _ k) (VarT n) = KindedTV n k
replaceTyVarName tvb _ = tvb
applyClass :: Name -> Name -> Pred
#if MIN_VERSION_template_haskell(2,10,0)
applyClass con t = AppT (ConT con) (VarT t)
#else
applyClass con t = ClassP con [VarT t]
#endif
canEtaReduce :: [Type] -> [Type] -> Bool
canEtaReduce remaining dropped =
all isTyVar dropped
&& allDistinct nbs
&& not (any (`mentionsNameBase` nbs) remaining)
where
nbs :: [NameBase]
nbs = map varTToNameBase dropped
varTToName :: Type -> Name
varTToName (VarT n) = n
varTToName (SigT t _) = varTToName t
varTToName _ = error "Not a type variable!"
varTToNameBase :: Type -> NameBase
varTToNameBase = NameBase . varTToName
unSigT :: Type -> Type
unSigT (SigT t _) = t
unSigT t = t
isTyVar :: Type -> Bool
isTyVar (VarT _) = True
isTyVar (SigT t _) = isTyVar t
isTyVar _ = False
isTyFamily :: Type -> Q Bool
isTyFamily (ConT n) = do
info <- reify n
return $ case info of
#if MIN_VERSION_template_haskell(2,11,0)
FamilyI OpenTypeFamilyD{} _ -> True
#elif MIN_VERSION_template_haskell(2,7,0)
FamilyI (FamilyD TypeFam _ _ _) _ -> True
#else
TyConI (FamilyD TypeFam _ _ _) -> True
#endif
#if MIN_VERSION_template_haskell(2,9,0)
FamilyI ClosedTypeFamilyD{} _ -> True
#endif
_ -> False
isTyFamily _ = return False
allDistinct :: Ord a => [a] -> Bool
allDistinct = allDistinct' Set.empty
where
allDistinct' :: Ord a => Set a -> [a] -> Bool
allDistinct' uniqs (x:xs)
| x `Set.member` uniqs = False
| otherwise = allDistinct' (Set.insert x uniqs) xs
allDistinct' _ _ = True
mentionsNameBase :: Type -> [NameBase] -> Bool
mentionsNameBase = go Set.empty
where
go :: Set NameBase -> Type -> [NameBase] -> Bool
go foralls (ForallT tvbs _ t) nbs =
go (foralls `Set.union` Set.fromList (map (NameBase . tvbName) tvbs)) t nbs
go foralls (AppT t1 t2) nbs = go foralls t1 nbs || go foralls t2 nbs
go foralls (SigT t _) nbs = go foralls t nbs
go foralls (VarT n) nbs = varNb `elem` nbs && not (varNb `Set.member` foralls)
where
varNb = NameBase n
go _ _ _ = False
predMentionsNameBase :: Pred -> [NameBase] -> Bool
#if MIN_VERSION_template_haskell(2,10,0)
predMentionsNameBase = mentionsNameBase
#else
predMentionsNameBase (ClassP _ tys) nbs = any (`mentionsNameBase` nbs) tys
predMentionsNameBase (EqualP t1 t2) nbs = mentionsNameBase t1 nbs || mentionsNameBase t2 nbs
#endif
numKindArrows :: Kind -> Int
numKindArrows k = length (uncurryKind k) 1
applyTy :: Type -> [Type] -> Type
applyTy = foldl' AppT
applyTyCon :: Name -> [Type] -> Type
applyTyCon = applyTy . ConT
unapplyTy :: Type -> NonEmpty Type
unapplyTy = NE.reverse . go
where
go :: Type -> NonEmpty Type
go (AppT t1 t2) = t2 <| go t1
go (SigT t _) = go t
go t = t :| []
uncurryTy :: Type -> NonEmpty Type
uncurryTy (AppT (AppT ArrowT t1) t2) = t1 <| uncurryTy t2
uncurryTy (SigT t _) = uncurryTy t
uncurryTy t = t :| []
uncurryKind :: Kind -> NonEmpty Kind
#if MIN_VERSION_template_haskell(2,8,0)
uncurryKind = uncurryTy
#else
uncurryKind (ArrowK k1 k2) = k1 <| uncurryKind k2
uncurryKind k = k :| []
#endif
wellKinded :: [Kind] -> Bool
wellKinded = all canRealizeKindStar
canRealizeKindStarChain :: Kind -> Bool
canRealizeKindStarChain = all canRealizeKindStar . uncurryKind
canRealizeKindStar :: Kind -> Bool
canRealizeKindStar k = case uncurryKind k of
k' :| [] -> case k' of
#if MIN_VERSION_template_haskell(2,8,0)
StarT -> True
(VarT _) -> True
#else
StarK -> True
#endif
_ -> False
_ -> False
createKindChain :: Int -> Kind
createKindChain = go starK
where
go :: Kind -> Int -> Kind
go k !0 = k
#if MIN_VERSION_template_haskell(2,8,0)
go k !n = go (AppT (AppT ArrowT StarT) k) (n 1)
#else
go k !n = go (ArrowK StarK k) (n 1)
#endif
# if MIN_VERSION_template_haskell(2,8,0) && __GLASGOW_HASKELL__ < 710
distinctKindVars :: Kind -> Set Name
distinctKindVars (AppT k1 k2) = distinctKindVars k1 `Set.union` distinctKindVars k2
distinctKindVars (SigT k _) = distinctKindVars k
distinctKindVars (VarT k) = Set.singleton k
distinctKindVars _ = Set.empty
#endif
#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710
tvbToType :: TyVarBndr -> Type
tvbToType (PlainTV n) = VarT n
tvbToType (KindedTV n k) = SigT (VarT n) k
#endif
#if MIN_VERSION_template_haskell(2,7,0)
constructorName :: Con -> Name
constructorName (NormalC name _ ) = name
constructorName (RecC name _ ) = name
constructorName (InfixC _ name _ ) = name
constructorName (ForallC _ _ con) = constructorName con
#endif