{-# LANGUAGE CPP              #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternGuards    #-}
{-# LANGUAGE TypeFamilies     #-}
{-# LANGUAGE BangPatterns     #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Convert
-- Copyright   :  (c) Isaac Dupree 2009,
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Conversion between TyThing and HsDecl. This functionality may be moved into
-- GHC at some point.
-----------------------------------------------------------------------------
module Haddock.Convert (
  tyThingToLHsDecl,
  synifyInstHead,
  synifyFamInst,
  PrintRuntimeReps(..),
) where

import Control.DeepSeq (force)
import GHC.Data.Bag ( emptyBag )
import GHC.Types.Basic ( TupleSort(..), DefMethSpec(..), TopLevelFlag(..) )
import GHC.Types.SourceText (SourceText(..))
import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Core.Class
import GHC.Core.Coercion.Axiom
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.FamInstEnv
import GHC.Core.PatSyn
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Compare( eqTypes )

import GHC.Hs
import GHC.Types.TyThing
import GHC.Types.Name
import GHC.Unit.Types
import GHC.Types.Id          ( setIdType, idType )
import GHC.Types.Name.Set    ( emptyNameSet )
import GHC.Types.Name.Reader ( mkVarUnqual )
import GHC.Builtin.Types.Prim ( alphaTyVars )
import GHC.Builtin.Types ( eqTyConName, listTyConName, liftedTypeKindTyConName
                  , unitTy, promotedNilDataCon, promotedConsDataCon )
import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey
                 , liftedDataConKey, boxedRepDataConKey )
import GHC.Types.Unique ( getUnique )
import GHC.Utils.Misc ( chkAppend, dropList, equalLength
                      , filterByList, filterOut )
import GHC.Utils.Panic.Plain ( assert )
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.SrcLoc

import Language.Haskell.Syntax.Basic (FieldLabelString(..))

import Haddock.Types
import Haddock.GhcUtils                      ( orderedFVs, defaultRuntimeRepVars, mkEmptySigType )
import Haddock.Interface.RenameType

import Data.Either (lefts, rights)
import Data.Maybe                            ( catMaybes, mapMaybe, maybeToList )
import Data.Either                           ( partitionEithers )


-- | Whether or not to default 'RuntimeRep' variables to 'LiftedRep'. Check
-- out Note [Defaulting RuntimeRep variables] in GHC.Iface.Type for the
-- motivation.
data PrintRuntimeReps = ShowRuntimeRep | HideRuntimeRep deriving Arity -> PrintRuntimeReps -> ShowS
[PrintRuntimeReps] -> ShowS
PrintRuntimeReps -> String
(Arity -> PrintRuntimeReps -> ShowS)
-> (PrintRuntimeReps -> String)
-> ([PrintRuntimeReps] -> ShowS)
-> Show PrintRuntimeReps
forall a.
(Arity -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Arity -> PrintRuntimeReps -> ShowS
showsPrec :: Arity -> PrintRuntimeReps -> ShowS
$cshow :: PrintRuntimeReps -> String
show :: PrintRuntimeReps -> String
$cshowList :: [PrintRuntimeReps] -> ShowS
showList :: [PrintRuntimeReps] -> ShowS
Show

-- the main function here! yay!
tyThingToLHsDecl
  :: PrintRuntimeReps
  -> TyThing
  -> Either String ([String], (HsDecl GhcRn))
tyThingToLHsDecl :: PrintRuntimeReps
-> TyThing -> Either String ([String], HsDecl GhcRn)
tyThingToLHsDecl PrintRuntimeReps
prr TyThing
t = case TyThing
t of
  -- ids (functions and zero-argument a.k.a. CAFs) get a type signature.
  -- Including built-in functions like seq.
  -- foreign-imported functions could be represented with ForD
  -- instead of SigD if we wanted...
  --
  -- in a future code version we could turn idVarDetails = foreign-call
  -- into a ForD instead of a SigD if we wanted.  Haddock doesn't
  -- need to care.
  AnId TyVar
i -> HsDecl GhcRn -> Either String ([String], HsDecl GhcRn)
forall {m :: * -> *} {a} {b}. (Monad m, Monoid a) => b -> m (a, b)
allOK (HsDecl GhcRn -> Either String ([String], HsDecl GhcRn))
-> HsDecl GhcRn -> Either String ([String], HsDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ XSigD GhcRn -> Sig GhcRn -> HsDecl GhcRn
forall p. XSigD p -> Sig p -> HsDecl p
SigD XSigD GhcRn
NoExtField
noExtField (PrintRuntimeReps
-> SynifyTypeState -> [TyVar] -> TyVar -> Sig GhcRn
synifyIdSig PrintRuntimeReps
prr SynifyTypeState
ImplicitizeForAll [] TyVar
i)

  -- type-constructors (e.g. Maybe) are complicated, put the definition
  -- later in the file (also it's used for class associated-types too.)
  ATyCon TyCon
tc
    | Just Class
cl <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc -- classes are just a little tedious
    -> let extractFamilyDecl :: TyClDecl a -> Either String (FamilyDecl a)
           extractFamilyDecl :: forall a. TyClDecl a -> Either String (FamilyDecl a)
extractFamilyDecl (FamDecl XFamDecl a
_ FamilyDecl a
d) = FamilyDecl a -> Either String (FamilyDecl a)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return FamilyDecl a
d
           extractFamilyDecl TyClDecl a
_           =
             String -> Either String (FamilyDecl a)
forall a b. a -> Either a b
Left String
"tyThingToLHsDecl: impossible associated tycon"

           cvt :: HsTyVarBndr flag GhcRn -> HsType GhcRn
             -- Without this signature, we trigger GHC#18932
           cvt :: forall flag. HsTyVarBndr flag GhcRn -> HsType GhcRn
cvt (UserTyVar XUserTyVar GhcRn
_ flag
_ LIdP GhcRn
n) = XTyVar GhcRn -> PromotionFlag -> LIdP GhcRn -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar [AddEpAnn]
XTyVar GhcRn
forall a. NoAnn a => a
noAnn PromotionFlag
NotPromoted LIdP GhcRn
n
           cvt (KindedTyVar XKindedTyVar GhcRn
_ flag
_ (L SrcSpanAnnN
name_loc Name
n) LHsKind GhcRn
kind) = XKindSig GhcRn -> LHsKind GhcRn -> LHsKind GhcRn -> HsType GhcRn
forall pass.
XKindSig pass -> LHsType pass -> LHsType pass -> HsType pass
HsKindSig [AddEpAnn]
XKindSig GhcRn
forall a. NoAnn a => a
noAnn
              (SrcSpanAnnA
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnN
name_loc) (XTyVar GhcRn -> PromotionFlag -> LIdP GhcRn -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar [AddEpAnn]
XTyVar GhcRn
forall a. NoAnn a => a
noAnn PromotionFlag
NotPromoted (SrcSpanAnnN -> Name -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
name_loc Name
n))) LHsKind GhcRn
kind

           -- | Convert a LHsTyVarBndr to an equivalent LHsType.
           hsLTyVarBndrToType :: LHsTyVarBndr flag GhcRn -> LHsType GhcRn
           hsLTyVarBndrToType :: forall flag. LHsTyVarBndr flag GhcRn -> LHsKind GhcRn
hsLTyVarBndrToType = (HsTyVarBndr flag GhcRn -> HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsTyVarBndr flag GhcRn -> HsType GhcRn
forall flag. HsTyVarBndr flag GhcRn -> HsType GhcRn
cvt

           extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn
           extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn
extractFamDefDecl FamilyDecl GhcRn
fd Type
rhs =
             XCTyFamInstDecl GhcRn
-> FamEqn GhcRn (LHsKind GhcRn) -> TyFamDefltDecl GhcRn
forall pass.
XCTyFamInstDecl pass -> TyFamInstEqn pass -> TyFamInstDecl pass
TyFamInstDecl [AddEpAnn]
XCTyFamInstDecl GhcRn
forall a. NoAnn a => a
noAnn (FamEqn GhcRn (LHsKind GhcRn) -> TyFamDefltDecl GhcRn)
-> FamEqn GhcRn (LHsKind GhcRn) -> TyFamDefltDecl GhcRn
forall a b. (a -> b) -> a -> b
$ FamEqn
             { feqn_ext :: XCFamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
feqn_ext = [AddEpAnn]
XCFamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall a. NoAnn a => a
noAnn
             , feqn_tycon :: LIdP GhcRn
feqn_tycon = FamilyDecl GhcRn -> LIdP GhcRn
forall pass. FamilyDecl pass -> LIdP pass
fdLName FamilyDecl GhcRn
fd
             , feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcRn
feqn_bndrs = HsOuterImplicit{hso_ximplicit :: XHsOuterImplicit GhcRn
hso_ximplicit = LHsQTyVars GhcRn -> XHsQTvs GhcRn
forall pass. LHsQTyVars pass -> XHsQTvs pass
hsq_ext (FamilyDecl GhcRn -> LHsQTyVars GhcRn
forall pass. FamilyDecl pass -> LHsQTyVars pass
fdTyVars FamilyDecl GhcRn
fd)}
             , feqn_pats :: HsFamEqnPats GhcRn
feqn_pats = (GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)
 -> LHsTypeArg GhcRn)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)]
-> HsFamEqnPats GhcRn
forall a b. (a -> b) -> [a] -> [b]
map (XValArg GhcRn
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsArg
     GhcRn
     (GenLocated SrcSpanAnnA (HsType GhcRn))
     (GenLocated SrcSpanAnnA (HsType GhcRn))
forall p tm ty. XValArg p -> tm -> HsArg p tm ty
HsValArg NoExtField
XValArg GhcRn
noExtField (GenLocated SrcSpanAnnA (HsType GhcRn)
 -> HsArg
      GhcRn
      (GenLocated SrcSpanAnnA (HsType GhcRn))
      (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> (GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)
    -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)
-> HsArg
     GhcRn
     (GenLocated SrcSpanAnnA (HsType GhcRn))
     (GenLocated SrcSpanAnnA (HsType GhcRn))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsTyVarBndr (HsBndrVis GhcRn) GhcRn -> LHsKind GhcRn
GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall flag. LHsTyVarBndr flag GhcRn -> LHsKind GhcRn
hsLTyVarBndrToType) ([GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)]
 -> HsFamEqnPats GhcRn)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)]
-> HsFamEqnPats GhcRn
forall a b. (a -> b) -> a -> b
$
                           LHsQTyVars GhcRn -> [LHsTyVarBndr (HsBndrVis GhcRn) GhcRn]
forall pass.
LHsQTyVars pass -> [LHsTyVarBndr (HsBndrVis pass) pass]
hsq_explicit (LHsQTyVars GhcRn -> [LHsTyVarBndr (HsBndrVis GhcRn) GhcRn])
-> LHsQTyVars GhcRn -> [LHsTyVarBndr (HsBndrVis GhcRn) GhcRn]
forall a b. (a -> b) -> a -> b
$ FamilyDecl GhcRn -> LHsQTyVars GhcRn
forall pass. FamilyDecl pass -> LHsQTyVars pass
fdTyVars FamilyDecl GhcRn
fd
             , feqn_fixity :: LexicalFixity
feqn_fixity = FamilyDecl GhcRn -> LexicalFixity
forall pass. FamilyDecl pass -> LexicalFixity
fdFixity FamilyDecl GhcRn
fd
             , feqn_rhs :: GenLocated SrcSpanAnnA (HsType GhcRn)
feqn_rhs = SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [] Type
rhs }

           extractAtItem
             :: ClassATItem
             -> Either String (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))
           extractAtItem :: ClassATItem
-> Either String (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))
extractAtItem (ATI TyCon
at_tc Maybe (Type, TyFamEqnValidityInfo)
def) = do
             tyDecl <- PrintRuntimeReps
-> Maybe (CoAxiom (ZonkAny 0))
-> TyCon
-> Either String (TyClDecl GhcRn)
forall (br :: BranchFlag).
PrintRuntimeReps
-> Maybe (CoAxiom br) -> TyCon -> Either String (TyClDecl GhcRn)
synifyTyCon PrintRuntimeReps
prr Maybe (CoAxiom (ZonkAny 0))
forall a. Maybe a
Nothing TyCon
at_tc
             famDecl <- extractFamilyDecl tyDecl
             let defEqnTy = ((Type, TyFamEqnValidityInfo)
 -> GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn))
-> Maybe (Type, TyFamEqnValidityInfo)
-> Maybe (GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyFamDefltDecl GhcRn
-> GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (TyFamDefltDecl GhcRn
 -> GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn))
-> ((Type, TyFamEqnValidityInfo) -> TyFamDefltDecl GhcRn)
-> (Type, TyFamEqnValidityInfo)
-> GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn
extractFamDefDecl FamilyDecl GhcRn
famDecl (Type -> TyFamDefltDecl GhcRn)
-> ((Type, TyFamEqnValidityInfo) -> Type)
-> (Type, TyFamEqnValidityInfo)
-> TyFamDefltDecl GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type, TyFamEqnValidityInfo) -> Type
forall a b. (a, b) -> a
fst) Maybe (Type, TyFamEqnValidityInfo)
def
             pure (noLocA famDecl, defEqnTy)

           atTyClDecls :: [Either
   String
   (GenLocated SrcSpanAnnA (FamilyDecl GhcRn),
    Maybe (GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn)))]
atTyClDecls = (ClassATItem
 -> Either
      String
      (GenLocated SrcSpanAnnA (FamilyDecl GhcRn),
       Maybe (GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn))))
-> [ClassATItem]
-> [Either
      String
      (GenLocated SrcSpanAnnA (FamilyDecl GhcRn),
       Maybe (GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn)))]
forall a b. (a -> b) -> [a] -> [b]
map ClassATItem
-> Either String (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))
ClassATItem
-> Either
     String
     (GenLocated SrcSpanAnnA (FamilyDecl GhcRn),
      Maybe (GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn)))
extractAtItem (Class -> [ClassATItem]
classATItems Class
cl)
           ([GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
atFamDecls, [Maybe (GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn))]
atDefFamDecls) = [(GenLocated SrcSpanAnnA (FamilyDecl GhcRn),
  Maybe (GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn)))]
-> ([GenLocated SrcSpanAnnA (FamilyDecl GhcRn)],
    [Maybe (GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn))])
forall a b. [(a, b)] -> ([a], [b])
unzip ([Either
   String
   (GenLocated SrcSpanAnnA (FamilyDecl GhcRn),
    Maybe (GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn)))]
-> [(GenLocated SrcSpanAnnA (FamilyDecl GhcRn),
     Maybe (GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn)))]
forall a b. [Either a b] -> [b]
rights [Either
   String
   (GenLocated SrcSpanAnnA (FamilyDecl GhcRn),
    Maybe (GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn)))]
atTyClDecls)
           vs :: [TyVar]
vs = TyCon -> [TyVar]
tyConVisibleTyVars (Class -> TyCon
classTyCon Class
cl)

       in [String] -> HsDecl GhcRn -> Either String ([String], HsDecl GhcRn)
forall {m :: * -> *} {a} {b}. Monad m => a -> b -> m (a, b)
withErrs ([Either
   String
   (GenLocated SrcSpanAnnA (FamilyDecl GhcRn),
    Maybe (GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn)))]
-> [String]
forall a b. [Either a b] -> [a]
lefts [Either
   String
   (GenLocated SrcSpanAnnA (FamilyDecl GhcRn),
    Maybe (GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn)))]
atTyClDecls) (HsDecl GhcRn -> Either String ([String], HsDecl GhcRn))
-> (TyClDecl GhcRn -> HsDecl GhcRn)
-> TyClDecl GhcRn
-> Either String ([String], HsDecl GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XTyClD GhcRn -> TyClDecl GhcRn -> HsDecl GhcRn
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcRn
NoExtField
noExtField (TyClDecl GhcRn -> Either String ([String], HsDecl GhcRn))
-> TyClDecl GhcRn -> Either String ([String], HsDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ ClassDecl
          { -- This should not always be `Just`, since `Just` of an empty
            -- context causes pretty printing to print `()` for the
            -- context
            tcdCtxt :: Maybe (LHsContext GhcRn)
tcdCtxt =
              case Class -> [Type]
classSCTheta Class
cl of
                [] -> Maybe (LHsContext GhcRn)
Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
forall a. Maybe a
Nothing
                [Type]
th -> LHsContext GhcRn -> Maybe (LHsContext GhcRn)
forall a. a -> Maybe a
Just (LHsContext GhcRn -> Maybe (LHsContext GhcRn))
-> LHsContext GhcRn -> Maybe (LHsContext GhcRn)
forall a b. (a -> b) -> a -> b
$ [Type] -> LHsContext GhcRn
synifyCtx [Type]
th

          , tcdLName :: LIdP GhcRn
tcdLName = Class -> LocatedN Name
forall n. NamedThing n => n -> LocatedN Name
synifyNameN Class
cl
          , tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars = [TyVar] -> LHsQTyVars GhcRn
synifyTyVars [TyVar]
vs
          , tcdFixity :: LexicalFixity
tcdFixity = Class -> LexicalFixity
forall n. NamedThing n => n -> LexicalFixity
synifyFixity Class
cl
          , tcdFDs :: [LHsFunDep GhcRn]
tcdFDs = (([TyVar], [TyVar]) -> LHsFunDep GhcRn)
-> [([TyVar], [TyVar])] -> [LHsFunDep GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (\ ([TyVar]
l,[TyVar]
r) -> FunDep GhcRn -> GenLocated SrcSpanAnnA (FunDep GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA
                          (XCFunDep GhcRn -> [LIdP GhcRn] -> [LIdP GhcRn] -> FunDep GhcRn
forall pass.
XCFunDep pass -> [LIdP pass] -> [LIdP pass] -> FunDep pass
FunDep [AddEpAnn]
XCFunDep GhcRn
forall a. NoAnn a => a
noAnn ((TyVar -> LocatedN Name) -> [TyVar] -> [LocatedN Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> LocatedN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Name -> LocatedN Name)
-> (TyVar -> Name) -> TyVar -> LocatedN Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Name
forall a. NamedThing a => a -> Name
getName) [TyVar]
l) ((TyVar -> LocatedN Name) -> [TyVar] -> [LocatedN Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> LocatedN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Name -> LocatedN Name)
-> (TyVar -> Name) -> TyVar -> LocatedN Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Name
forall a. NamedThing a => a -> Name
getName) [TyVar]
r)) ) ([([TyVar], [TyVar])] -> [LHsFunDep GhcRn])
-> [([TyVar], [TyVar])] -> [LHsFunDep GhcRn]
forall a b. (a -> b) -> a -> b
$
                          ([TyVar], [([TyVar], [TyVar])]) -> [([TyVar], [TyVar])]
forall a b. (a, b) -> b
snd (([TyVar], [([TyVar], [TyVar])]) -> [([TyVar], [TyVar])])
-> ([TyVar], [([TyVar], [TyVar])]) -> [([TyVar], [TyVar])]
forall a b. (a -> b) -> a -> b
$ Class -> ([TyVar], [([TyVar], [TyVar])])
classTvsFds Class
cl
          , tcdSigs :: [LSig GhcRn]
tcdSigs = Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XMinimalSig GhcRn -> LBooleanFormula (LIdP GhcRn) -> Sig GhcRn
forall pass.
XMinimalSig pass -> LBooleanFormula (LIdP pass) -> Sig pass
MinimalSig ([AddEpAnn]
forall a. NoAnn a => a
noAnn, SourceText
NoSourceText) (GenLocated SrcSpanAnnL (BooleanFormula (LocatedN Name))
 -> Sig GhcRn)
-> (ClassMinimalDef
    -> GenLocated SrcSpanAnnL (BooleanFormula (LocatedN Name)))
-> ClassMinimalDef
-> Sig GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BooleanFormula (LocatedN Name)
-> GenLocated SrcSpanAnnL (BooleanFormula (LocatedN Name))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (BooleanFormula (LocatedN Name)
 -> GenLocated SrcSpanAnnL (BooleanFormula (LocatedN Name)))
-> (ClassMinimalDef -> BooleanFormula (LocatedN Name))
-> ClassMinimalDef
-> GenLocated SrcSpanAnnL (BooleanFormula (LocatedN Name))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> LocatedN Name)
-> ClassMinimalDef -> BooleanFormula (LocatedN Name)
forall a b. (a -> b) -> BooleanFormula a -> BooleanFormula b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> LocatedN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (ClassMinimalDef -> Sig GhcRn) -> ClassMinimalDef -> Sig GhcRn
forall a b. (a -> b) -> a -> b
$ Class -> ClassMinimalDef
classMinimalDef Class
cl) GenLocated SrcSpanAnnA (Sig GhcRn)
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. a -> [a] -> [a]
:
                        [ Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA Sig GhcRn
tcdSig
                        | ClassOpItem
clsOp <- Class -> [ClassOpItem]
classOpItems Class
cl
                        , Sig GhcRn
tcdSig <- [TyVar] -> ClassOpItem -> [Sig GhcRn]
synifyTcIdSig [TyVar]
vs ClassOpItem
clsOp ]
          , tcdMeths :: LHsBinds GhcRn
tcdMeths = LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
forall a. Bag a
emptyBag --ignore default method definitions, they don't affect signature
          -- class associated-types are a subset of TyCon:
          , tcdATs :: [LFamilyDecl GhcRn]
tcdATs = [LFamilyDecl GhcRn]
[GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
atFamDecls
          , tcdATDefs :: [LTyFamDefltDecl GhcRn]
tcdATDefs = [Maybe (GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn))]
-> [GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (GenLocated SrcSpanAnnA (TyFamDefltDecl GhcRn))]
atDefFamDecls
          , tcdDocs :: [LDocDecl GhcRn]
tcdDocs = [] --we don't have any docs at this point
          , tcdCExt :: XClassDecl GhcRn
tcdCExt = XClassDecl GhcRn
NameSet
emptyNameSet
          }
    | Bool
otherwise
    -> PrintRuntimeReps
-> Maybe (CoAxiom (ZonkAny 1))
-> TyCon
-> Either String (TyClDecl GhcRn)
forall (br :: BranchFlag).
PrintRuntimeReps
-> Maybe (CoAxiom br) -> TyCon -> Either String (TyClDecl GhcRn)
synifyTyCon PrintRuntimeReps
prr Maybe (CoAxiom (ZonkAny 1))
forall a. Maybe a
Nothing TyCon
tc Either String (TyClDecl GhcRn)
-> (TyClDecl GhcRn -> Either String ([String], HsDecl GhcRn))
-> Either String ([String], HsDecl GhcRn)
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HsDecl GhcRn -> Either String ([String], HsDecl GhcRn)
forall {m :: * -> *} {a} {b}. (Monad m, Monoid a) => b -> m (a, b)
allOK (HsDecl GhcRn -> Either String ([String], HsDecl GhcRn))
-> (TyClDecl GhcRn -> HsDecl GhcRn)
-> TyClDecl GhcRn
-> Either String ([String], HsDecl GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XTyClD GhcRn -> TyClDecl GhcRn -> HsDecl GhcRn
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcRn
NoExtField
noExtField

  -- type-constructors (e.g. Maybe) are complicated, put the definition
  -- later in the file (also it's used for class associated-types too.)
  ACoAxiom CoAxiom Branched
ax -> CoAxiom Branched -> Either String (HsDecl GhcRn)
forall (br :: BranchFlag).
CoAxiom br -> Either String (HsDecl GhcRn)
synifyAxiom CoAxiom Branched
ax Either String (HsDecl GhcRn)
-> (HsDecl GhcRn -> Either String ([String], HsDecl GhcRn))
-> Either String ([String], HsDecl GhcRn)
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HsDecl GhcRn -> Either String ([String], HsDecl GhcRn)
forall {m :: * -> *} {a} {b}. (Monad m, Monoid a) => b -> m (a, b)
allOK

  -- a data-constructor alone just gets rendered as a function:
  AConLike (RealDataCon DataCon
dc) -> HsDecl GhcRn -> Either String ([String], HsDecl GhcRn)
forall {m :: * -> *} {a} {b}. (Monad m, Monoid a) => b -> m (a, b)
allOK (HsDecl GhcRn -> Either String ([String], HsDecl GhcRn))
-> HsDecl GhcRn -> Either String ([String], HsDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ XSigD GhcRn -> Sig GhcRn -> HsDecl GhcRn
forall p. XSigD p -> Sig p -> HsDecl p
SigD XSigD GhcRn
NoExtField
noExtField (XTypeSig GhcRn -> [LIdP GhcRn] -> LHsSigWcType GhcRn -> Sig GhcRn
forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig XTypeSig GhcRn
AnnSig
forall a. NoAnn a => a
noAnn [DataCon -> LocatedN Name
forall n. NamedThing n => n -> LocatedN Name
synifyNameN DataCon
dc]
    (SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn
synifySigWcType SynifyTypeState
ImplicitizeForAll [] (DataCon -> Type
dataConWrapperType DataCon
dc)))

  AConLike (PatSynCon PatSyn
ps) ->
    HsDecl GhcRn -> Either String ([String], HsDecl GhcRn)
forall {m :: * -> *} {a} {b}. (Monad m, Monoid a) => b -> m (a, b)
allOK (HsDecl GhcRn -> Either String ([String], HsDecl GhcRn))
-> (Sig GhcRn -> HsDecl GhcRn)
-> Sig GhcRn
-> Either String ([String], HsDecl GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XSigD GhcRn -> Sig GhcRn -> HsDecl GhcRn
forall p. XSigD p -> Sig p -> HsDecl p
SigD XSigD GhcRn
NoExtField
noExtField (Sig GhcRn -> Either String ([String], HsDecl GhcRn))
-> Sig GhcRn -> Either String ([String], HsDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ XPatSynSig GhcRn -> [LIdP GhcRn] -> LHsSigType GhcRn -> Sig GhcRn
forall pass.
XPatSynSig pass -> [LIdP pass] -> LHsSigType pass -> Sig pass
PatSynSig XPatSynSig GhcRn
AnnSig
forall a. NoAnn a => a
noAnn [PatSyn -> LocatedN Name
forall n. NamedThing n => n -> LocatedN Name
synifyNameN PatSyn
ps] (PatSyn -> LHsSigType GhcRn
synifyPatSynSigType PatSyn
ps)
  where
    withErrs :: a -> b -> m (a, b)
withErrs a
e b
x = (a, b) -> m (a, b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
e, b
x)
    allOK :: b -> m (a, b)
allOK b
x = (a, b) -> m (a, b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
forall a. Monoid a => a
mempty, b
x)

synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn
synifyAxBranch :: TyCon -> CoAxBranch -> FamEqn GhcRn (LHsKind GhcRn)
synifyAxBranch TyCon
tc (CoAxBranch { cab_tvs :: CoAxBranch -> [TyVar]
cab_tvs = [TyVar]
tkvs, cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
args, cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs })
  = let name :: LocatedN Name
name            = TyCon -> LocatedN Name
forall n. NamedThing n => n -> LocatedN Name
synifyNameN TyCon
tc
        args_types_only :: [Type]
args_types_only = TyCon -> [Type] -> [Type]
filterOutInvisibleTypes TyCon
tc [Type]
args
        typats :: [GenLocated SrcSpanAnnA (HsType GhcRn)]
typats          = (Type -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [Type] -> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType []) [Type]
args_types_only
        annot_typats :: [GenLocated SrcSpanAnnA (HsType GhcRn)]
annot_typats    = (Bool
 -> Type
 -> GenLocated SrcSpanAnnA (HsType GhcRn)
 -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [Bool]
-> [Type]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Bool -> Type -> LHsKind GhcRn -> LHsKind GhcRn
Bool
-> Type
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn)
annotHsType [Bool]
args_poly [Type]
args_types_only [GenLocated SrcSpanAnnA (HsType GhcRn)]
typats
        hs_rhs :: LHsKind GhcRn
hs_rhs          = SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [] Type
rhs
        outer_bndrs :: HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs     = HsOuterImplicit{hso_ximplicit :: XHsOuterImplicit GhcRn
hso_ximplicit = (TyVar -> Name) -> [TyVar] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Name
tyVarName [TyVar]
tkvs}
                                       -- TODO: this must change eventually
    in FamEqn { feqn_ext :: XCFamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
feqn_ext    = [AddEpAnn]
XCFamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall a. NoAnn a => a
noAnn
              , feqn_tycon :: LIdP GhcRn
feqn_tycon  = LIdP GhcRn
LocatedN Name
name
              , feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcRn
feqn_bndrs  = HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs
              , feqn_pats :: HsFamEqnPats GhcRn
feqn_pats   = (GenLocated SrcSpanAnnA (HsType GhcRn)
 -> HsArg
      GhcRn
      (GenLocated SrcSpanAnnA (HsType GhcRn))
      (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [HsArg
      GhcRn
      (GenLocated SrcSpanAnnA (HsType GhcRn))
      (GenLocated SrcSpanAnnA (HsType GhcRn))]
forall a b. (a -> b) -> [a] -> [b]
map (XValArg GhcRn
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsArg
     GhcRn
     (GenLocated SrcSpanAnnA (HsType GhcRn))
     (GenLocated SrcSpanAnnA (HsType GhcRn))
forall p tm ty. XValArg p -> tm -> HsArg p tm ty
HsValArg NoExtField
XValArg GhcRn
noExtField) [GenLocated SrcSpanAnnA (HsType GhcRn)]
annot_typats
              , feqn_fixity :: LexicalFixity
feqn_fixity = LocatedN Name -> LexicalFixity
forall n. NamedThing n => n -> LexicalFixity
synifyFixity LocatedN Name
name
              , feqn_rhs :: GenLocated SrcSpanAnnA (HsType GhcRn)
feqn_rhs    = LHsKind GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
hs_rhs }
  where
    args_poly :: [Bool]
args_poly = TyCon -> [Bool]
tyConArgsPolyKinded TyCon
tc

synifyAxiom :: CoAxiom br -> Either String (HsDecl GhcRn)
synifyAxiom :: forall (br :: BranchFlag).
CoAxiom br -> Either String (HsDecl GhcRn)
synifyAxiom ax :: CoAxiom br
ax@(CoAxiom { co_ax_tc :: forall (br :: BranchFlag). CoAxiom br -> TyCon
co_ax_tc = TyCon
tc })
  | TyCon -> Bool
isOpenTypeFamilyTyCon TyCon
tc
  , Just CoAxBranch
branch <- CoAxiom br -> Maybe CoAxBranch
forall (br :: BranchFlag). CoAxiom br -> Maybe CoAxBranch
coAxiomSingleBranch_maybe CoAxiom br
ax
  = HsDecl GhcRn -> Either String (HsDecl GhcRn)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsDecl GhcRn -> Either String (HsDecl GhcRn))
-> HsDecl GhcRn -> Either String (HsDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ XInstD GhcRn -> InstDecl GhcRn -> HsDecl GhcRn
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD XInstD GhcRn
NoExtField
noExtField
           (InstDecl GhcRn -> HsDecl GhcRn) -> InstDecl GhcRn -> HsDecl GhcRn
forall a b. (a -> b) -> a -> b
$ XTyFamInstD GhcRn -> TyFamDefltDecl GhcRn -> InstDecl GhcRn
forall pass.
XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass
TyFamInstD XTyFamInstD GhcRn
NoExtField
noExtField
           (TyFamDefltDecl GhcRn -> InstDecl GhcRn)
-> TyFamDefltDecl GhcRn -> InstDecl GhcRn
forall a b. (a -> b) -> a -> b
$ TyFamInstDecl { tfid_xtn :: XCTyFamInstDecl GhcRn
tfid_xtn = [AddEpAnn]
XCTyFamInstDecl GhcRn
forall a. NoAnn a => a
noAnn, tfid_eqn :: FamEqn GhcRn (LHsKind GhcRn)
tfid_eqn = TyCon -> CoAxBranch -> FamEqn GhcRn (LHsKind GhcRn)
synifyAxBranch TyCon
tc CoAxBranch
branch }

  | Just CoAxiom Branched
ax' <- TyCon -> Maybe (CoAxiom Branched)
isClosedSynFamilyTyConWithAxiom_maybe TyCon
tc
  , CoAxiom Branched -> Unique
forall a. Uniquable a => a -> Unique
getUnique CoAxiom Branched
ax' Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== CoAxiom br -> Unique
forall a. Uniquable a => a -> Unique
getUnique CoAxiom br
ax   -- without the getUniques, type error
  = PrintRuntimeReps
-> Maybe (CoAxiom br) -> TyCon -> Either String (TyClDecl GhcRn)
forall (br :: BranchFlag).
PrintRuntimeReps
-> Maybe (CoAxiom br) -> TyCon -> Either String (TyClDecl GhcRn)
synifyTyCon PrintRuntimeReps
ShowRuntimeRep (CoAxiom br -> Maybe (CoAxiom br)
forall a. a -> Maybe a
Just CoAxiom br
ax) TyCon
tc Either String (TyClDecl GhcRn)
-> (TyClDecl GhcRn -> Either String (HsDecl GhcRn))
-> Either String (HsDecl GhcRn)
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HsDecl GhcRn -> Either String (HsDecl GhcRn)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsDecl GhcRn -> Either String (HsDecl GhcRn))
-> (TyClDecl GhcRn -> HsDecl GhcRn)
-> TyClDecl GhcRn
-> Either String (HsDecl GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XTyClD GhcRn -> TyClDecl GhcRn -> HsDecl GhcRn
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcRn
NoExtField
noExtField

  | Bool
otherwise
  = String -> Either String (HsDecl GhcRn)
forall a b. a -> Either a b
Left String
"synifyAxiom: closed/open family confusion"

-- | Turn type constructors into data declarations, type families, or type synonyms
synifyTyCon
  :: PrintRuntimeReps
  -> Maybe (CoAxiom br)  -- ^ RHS of type synonym
  -> TyCon               -- ^ type constructor to convert
  -> Either String (TyClDecl GhcRn)
synifyTyCon :: forall (br :: BranchFlag).
PrintRuntimeReps
-> Maybe (CoAxiom br) -> TyCon -> Either String (TyClDecl GhcRn)
synifyTyCon PrintRuntimeReps
prr Maybe (CoAxiom br)
_coax TyCon
tc
  | TyCon -> Bool
isPrimTyCon TyCon
tc
  = TyClDecl GhcRn -> Either String (TyClDecl GhcRn)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyClDecl GhcRn -> Either String (TyClDecl GhcRn))
-> TyClDecl GhcRn -> Either String (TyClDecl GhcRn)
forall a b. (a -> b) -> a -> b
$
    DataDecl { tcdLName :: LIdP GhcRn
tcdLName = TyCon -> LocatedN Name
forall n. NamedThing n => n -> LocatedN Name
synifyNameN TyCon
tc
             , tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars = HsQTvs  { hsq_ext :: XHsQTvs GhcRn
hsq_ext = []   -- No kind polymorphism
                                   , hsq_explicit :: [LHsTyVarBndr (HsBndrVis GhcRn) GhcRn]
hsq_explicit = (Type
 -> TyVar
 -> GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn))
-> [Type]
-> [TyVar]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type
-> TyVar
-> GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)
forall {pass} {e} {a}.
(XBndrRequired pass ~ NoExtField, HasAnnotation e, NamedThing a) =>
Type -> a -> GenLocated e (HsTyVarBndr (HsBndrVis pass) GhcRn)
mk_hs_tv
                                                            ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
tyVarKinds)
                                                            [TyVar]
alphaTyVars --a, b, c... which are unfortunately all kind *
                                   }

           , tcdFixity :: LexicalFixity
tcdFixity = TyCon -> LexicalFixity
forall n. NamedThing n => n -> LexicalFixity
synifyFixity TyCon
tc

           , tcdDataDefn :: HsDataDefn GhcRn
tcdDataDefn = HsDataDefn { dd_ext :: XCHsDataDefn GhcRn
dd_ext = XCHsDataDefn GhcRn
NoExtField
noExtField
                                      , dd_cons :: DataDefnCons (LConDecl GhcRn)
dd_cons = Bool
-> [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
forall a. Bool -> [a] -> DataDefnCons a
DataTypeCons Bool
False []  -- No constructors; arbitrary lie, they are neither
                                                    -- algebraic data nor newtype:
                                      , dd_ctxt :: Maybe (LHsContext GhcRn)
dd_ctxt = Maybe (LHsContext GhcRn)
Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
forall a. Maybe a
Nothing
                                      , dd_cType :: Maybe (XRec GhcRn CType)
dd_cType = Maybe (XRec GhcRn CType)
Maybe (GenLocated SrcSpanAnnP CType)
forall a. Maybe a
Nothing
                                      , dd_kindSig :: Maybe (LHsKind GhcRn)
dd_kindSig = TyCon -> Maybe (LHsKind GhcRn)
synifyDataTyConReturnKind TyCon
tc
                                               -- we have their kind accurately:
                                      , dd_derivs :: HsDeriving GhcRn
dd_derivs = [] }
           , tcdDExt :: XDataDecl GhcRn
tcdDExt = Bool -> NameSet -> DataDeclRn
DataDeclRn Bool
False NameSet
emptyNameSet }
  where
    -- tyConTyVars doesn't work on fun/prim, but we can make them up:
    mk_hs_tv :: Type -> a -> GenLocated e (HsTyVarBndr (HsBndrVis pass) GhcRn)
mk_hs_tv Type
realKind a
fakeTyVar
      | Type -> Bool
isLiftedTypeKind Type
realKind = HsTyVarBndr (HsBndrVis pass) GhcRn
-> GenLocated e (HsTyVarBndr (HsBndrVis pass) GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsTyVarBndr (HsBndrVis pass) GhcRn
 -> GenLocated e (HsTyVarBndr (HsBndrVis pass) GhcRn))
-> HsTyVarBndr (HsBndrVis pass) GhcRn
-> GenLocated e (HsTyVarBndr (HsBndrVis pass) GhcRn)
forall a b. (a -> b) -> a -> b
$ XUserTyVar GhcRn
-> HsBndrVis pass
-> LIdP GhcRn
-> HsTyVarBndr (HsBndrVis pass) GhcRn
forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar XUserTyVar GhcRn
forall a. NoAnn a => a
noAnn (XBndrRequired pass -> HsBndrVis pass
forall pass. XBndrRequired pass -> HsBndrVis pass
HsBndrRequired NoExtField
XBndrRequired pass
noExtField) (Name -> LocatedN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (a -> Name
forall a. NamedThing a => a -> Name
getName a
fakeTyVar))
      | Bool
otherwise = HsTyVarBndr (HsBndrVis pass) GhcRn
-> GenLocated e (HsTyVarBndr (HsBndrVis pass) GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsTyVarBndr (HsBndrVis pass) GhcRn
 -> GenLocated e (HsTyVarBndr (HsBndrVis pass) GhcRn))
-> HsTyVarBndr (HsBndrVis pass) GhcRn
-> GenLocated e (HsTyVarBndr (HsBndrVis pass) GhcRn)
forall a b. (a -> b) -> a -> b
$ XKindedTyVar GhcRn
-> HsBndrVis pass
-> LIdP GhcRn
-> LHsKind GhcRn
-> HsTyVarBndr (HsBndrVis pass) GhcRn
forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar XKindedTyVar GhcRn
forall a. NoAnn a => a
noAnn (XBndrRequired pass -> HsBndrVis pass
forall pass. XBndrRequired pass -> HsBndrVis pass
HsBndrRequired NoExtField
XBndrRequired pass
noExtField) (Name -> LocatedN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (a -> Name
forall a. NamedThing a => a -> Name
getName a
fakeTyVar)) (Type -> LHsKind GhcRn
synifyKindSig Type
realKind)

    conKind :: Type
conKind = PrintRuntimeReps -> Type -> Type
defaultType PrintRuntimeReps
prr (TyCon -> Type
tyConKind TyCon
tc)
    tyVarKinds :: [Scaled Type]
tyVarKinds = ([Scaled Type], Type) -> [Scaled Type]
forall a b. (a, b) -> a
fst (([Scaled Type], Type) -> [Scaled Type])
-> (Type -> ([Scaled Type], Type)) -> Type -> [Scaled Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([Scaled Type], Type)
splitFunTys (Type -> ([Scaled Type], Type))
-> (Type -> Type) -> Type -> ([Scaled Type], Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([PiTyBinder], Type) -> Type
forall a b. (a, b) -> b
snd (([PiTyBinder], Type) -> Type)
-> (Type -> ([PiTyBinder], Type)) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([PiTyBinder], Type)
splitInvisPiTys (Type -> [Scaled Type]) -> Type -> [Scaled Type]
forall a b. (a -> b) -> a -> b
$ Type
conKind

synifyTyCon PrintRuntimeReps
_prr Maybe (CoAxiom br)
_coax TyCon
tc
  | Just FamTyConFlav
flav <- TyCon -> Maybe FamTyConFlav
famTyConFlav_maybe TyCon
tc
  = case FamTyConFlav
flav of
      -- Type families
      FamTyConFlav
OpenSynFamilyTyCon -> FamilyInfo GhcRn -> Either String (TyClDecl GhcRn)
mkFamDecl FamilyInfo GhcRn
forall pass. FamilyInfo pass
OpenTypeFamily
      ClosedSynFamilyTyCon Maybe (CoAxiom Branched)
mb
        | Just (CoAxiom { co_ax_branches :: forall (br :: BranchFlag). CoAxiom br -> Branches br
co_ax_branches = Branches Branched
branches }) <- Maybe (CoAxiom Branched)
mb
          -> FamilyInfo GhcRn -> Either String (TyClDecl GhcRn)
mkFamDecl (FamilyInfo GhcRn -> Either String (TyClDecl GhcRn))
-> FamilyInfo GhcRn -> Either String (TyClDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ Maybe [LTyFamInstEqn GhcRn] -> FamilyInfo GhcRn
forall pass. Maybe [LTyFamInstEqn pass] -> FamilyInfo pass
ClosedTypeFamily (Maybe [LTyFamInstEqn GhcRn] -> FamilyInfo GhcRn)
-> Maybe [LTyFamInstEqn GhcRn] -> FamilyInfo GhcRn
forall a b. (a -> b) -> a -> b
$ [LTyFamInstEqn GhcRn] -> Maybe [LTyFamInstEqn GhcRn]
forall a. a -> Maybe a
Just
            ([LTyFamInstEqn GhcRn] -> Maybe [LTyFamInstEqn GhcRn])
-> [LTyFamInstEqn GhcRn] -> Maybe [LTyFamInstEqn GhcRn]
forall a b. (a -> b) -> a -> b
$ (CoAxBranch
 -> GenLocated
      SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))))
-> [CoAxBranch]
-> [GenLocated
      SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
forall a b. (a -> b) -> [a] -> [b]
map (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated
     SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
 -> GenLocated
      SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))))
-> (CoAxBranch
    -> FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> CoAxBranch
-> GenLocated
     SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> CoAxBranch -> FamEqn GhcRn (LHsKind GhcRn)
synifyAxBranch TyCon
tc) (Branches Branched -> [CoAxBranch]
forall (br :: BranchFlag). Branches br -> [CoAxBranch]
fromBranches Branches Branched
branches)
        | Bool
otherwise
          -> FamilyInfo GhcRn -> Either String (TyClDecl GhcRn)
mkFamDecl (FamilyInfo GhcRn -> Either String (TyClDecl GhcRn))
-> FamilyInfo GhcRn -> Either String (TyClDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ Maybe [LTyFamInstEqn GhcRn] -> FamilyInfo GhcRn
forall pass. Maybe [LTyFamInstEqn pass] -> FamilyInfo pass
ClosedTypeFamily (Maybe [LTyFamInstEqn GhcRn] -> FamilyInfo GhcRn)
-> Maybe [LTyFamInstEqn GhcRn] -> FamilyInfo GhcRn
forall a b. (a -> b) -> a -> b
$ [GenLocated
   SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
-> Maybe
     [GenLocated
        SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
forall a. a -> Maybe a
Just []
      BuiltInSynFamTyCon {}
        -> FamilyInfo GhcRn -> Either String (TyClDecl GhcRn)
mkFamDecl (FamilyInfo GhcRn -> Either String (TyClDecl GhcRn))
-> FamilyInfo GhcRn -> Either String (TyClDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ Maybe [LTyFamInstEqn GhcRn] -> FamilyInfo GhcRn
forall pass. Maybe [LTyFamInstEqn pass] -> FamilyInfo pass
ClosedTypeFamily (Maybe [LTyFamInstEqn GhcRn] -> FamilyInfo GhcRn)
-> Maybe [LTyFamInstEqn GhcRn] -> FamilyInfo GhcRn
forall a b. (a -> b) -> a -> b
$ [GenLocated
   SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
-> Maybe
     [GenLocated
        SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
forall a. a -> Maybe a
Just []
      AbstractClosedSynFamilyTyCon {}
        -> FamilyInfo GhcRn -> Either String (TyClDecl GhcRn)
mkFamDecl (FamilyInfo GhcRn -> Either String (TyClDecl GhcRn))
-> FamilyInfo GhcRn -> Either String (TyClDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ Maybe [LTyFamInstEqn GhcRn] -> FamilyInfo GhcRn
forall pass. Maybe [LTyFamInstEqn pass] -> FamilyInfo pass
ClosedTypeFamily Maybe [LTyFamInstEqn GhcRn]
Maybe
  [GenLocated
     SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
forall a. Maybe a
Nothing
      DataFamilyTyCon {}
        -> FamilyInfo GhcRn -> Either String (TyClDecl GhcRn)
mkFamDecl FamilyInfo GhcRn
forall pass. FamilyInfo pass
DataFamily
  where
    resultVar :: Maybe Name
resultVar = TyCon -> Maybe Name
tyConFamilyResVar_maybe TyCon
tc
    mkFamDecl :: FamilyInfo GhcRn -> Either String (TyClDecl GhcRn)
mkFamDecl FamilyInfo GhcRn
i = TyClDecl GhcRn -> Either String (TyClDecl GhcRn)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyClDecl GhcRn -> Either String (TyClDecl GhcRn))
-> TyClDecl GhcRn -> Either String (TyClDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ XFamDecl GhcRn -> FamilyDecl GhcRn -> TyClDecl GhcRn
forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl XFamDecl GhcRn
NoExtField
noExtField (FamilyDecl GhcRn -> TyClDecl GhcRn)
-> FamilyDecl GhcRn -> TyClDecl GhcRn
forall a b. (a -> b) -> a -> b
$
      FamilyDecl
        { fdExt :: XCFamilyDecl GhcRn
fdExt = [AddEpAnn]
XCFamilyDecl GhcRn
forall a. NoAnn a => a
noAnn
        , fdInfo :: FamilyInfo GhcRn
fdInfo = FamilyInfo GhcRn
i
        , fdTopLevel :: TopLevelFlag
fdTopLevel = TopLevelFlag
TopLevel
        , fdLName :: LIdP GhcRn
fdLName = TyCon -> LocatedN Name
forall n. NamedThing n => n -> LocatedN Name
synifyNameN TyCon
tc
        , fdTyVars :: LHsQTyVars GhcRn
fdTyVars = [TyVar] -> LHsQTyVars GhcRn
synifyTyVars (TyCon -> [TyVar]
tyConVisibleTyVars TyCon
tc)
        , fdFixity :: LexicalFixity
fdFixity = TyCon -> LexicalFixity
forall n. NamedThing n => n -> LexicalFixity
synifyFixity TyCon
tc
        , fdResultSig :: LFamilyResultSig GhcRn
fdResultSig = Maybe Name -> Type -> LFamilyResultSig GhcRn
synifyFamilyResultSig Maybe Name
resultVar (TyCon -> Type
tyConResKind TyCon
tc)
        , fdInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
fdInjectivityAnn =
            Maybe Name
-> [TyVar] -> Injectivity -> Maybe (LInjectivityAnn GhcRn)
synifyInjectivityAnn
              Maybe Name
resultVar
              (TyCon -> [TyVar]
tyConTyVars TyCon
tc)
              (TyCon -> Injectivity
tyConInjectivityInfo TyCon
tc)
        }

synifyTyCon PrintRuntimeReps
_prr Maybe (CoAxiom br)
coax TyCon
tc
  -- type synonyms
  | Just Type
ty <- TyCon -> Maybe Type
synTyConRhs_maybe TyCon
tc
  = TyClDecl GhcRn -> Either String (TyClDecl GhcRn)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyClDecl GhcRn -> Either String (TyClDecl GhcRn))
-> TyClDecl GhcRn -> Either String (TyClDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ SynDecl { tcdSExt :: XSynDecl GhcRn
tcdSExt   = XSynDecl GhcRn
NameSet
emptyNameSet
                     , tcdLName :: LIdP GhcRn
tcdLName  = TyCon -> LocatedN Name
forall n. NamedThing n => n -> LocatedN Name
synifyNameN TyCon
tc
                     , tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars = [TyVar] -> LHsQTyVars GhcRn
synifyTyVars (TyCon -> [TyVar]
tyConVisibleTyVars TyCon
tc)
                     , tcdFixity :: LexicalFixity
tcdFixity = TyCon -> LexicalFixity
forall n. NamedThing n => n -> LexicalFixity
synifyFixity TyCon
tc
                     , tcdRhs :: LHsKind GhcRn
tcdRhs = SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [] Type
ty
                     }

  -- (closed) newtype and data
  | Bool
otherwise = do
  let -- This should not always be `Just`, since `Just` of an empty
      -- context causes pretty printing to print `()` for the context
      alg_ctx :: Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
alg_ctx =
        case TyCon -> [Type]
tyConStupidTheta TyCon
tc of
          [] -> Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
forall a. Maybe a
Nothing
          [Type]
th -> LHsContext GhcRn -> Maybe (LHsContext GhcRn)
forall a. a -> Maybe a
Just (LHsContext GhcRn -> Maybe (LHsContext GhcRn))
-> LHsContext GhcRn -> Maybe (LHsContext GhcRn)
forall a b. (a -> b) -> a -> b
$ [Type] -> LHsContext GhcRn
synifyCtx [Type]
th

      -- Data families are named according to their CoAxioms, not their TyCons
      name :: LocatedN Name
name = case Maybe (CoAxiom br)
coax of
        Just CoAxiom br
a -> CoAxiom br -> LocatedN Name
forall n. NamedThing n => n -> LocatedN Name
synifyNameN CoAxiom br
a
        Maybe (CoAxiom br)
_ -> TyCon -> LocatedN Name
forall n. NamedThing n => n -> LocatedN Name
synifyNameN TyCon
tc

      -- For a data declaration:
      --   data Vec :: Nat -> Type -> Type where
      -- GHC will still report visible tyvars with default names 'a' and 'b'.
      -- Since 'Nat' is not inhabited by lifted types, 'a' will be given a kind
      -- signature (due to the logic in 'synify_ty_var'). Similarly, 'Vec'
      -- constructs lifted types and will therefore not be given a result kind
      -- signature. Thus, the generated documentation for 'Vec' will look like:
      -- data Vec (a :: Nat) b where
      tyvars :: LHsQTyVars GhcRn
tyvars = [TyVar] -> LHsQTyVars GhcRn
synifyTyVars (TyCon -> [TyVar]
tyConVisibleTyVars TyCon
tc)
      kindSig :: Maybe (LHsKind GhcRn)
kindSig = TyCon -> Maybe (LHsKind GhcRn)
synifyDataTyConReturnKind TyCon
tc

      -- The data constructors.
      --
      -- Any data-constructors not exported from the module that *defines* the
      -- type will not (cannot) be included.
      --
      -- Very simple constructors, Haskell98 with no existentials or anything,
      -- probably look nicer in non-GADT syntax.  In source code, all constructors
      -- must be declared with the same (GADT vs. not) syntax, and it probably
      -- is less confusing to follow that principle for the documentation as well.
      --
      -- There is no sensible infix-representation for GADT-syntax constructor
      -- declarations.  They cannot be made in source code, but we could end up
      -- with some here in the case where some constructors use existentials.
      -- That seems like an acceptable compromise (they'll just be documented
      -- in prefix position), since, otherwise, the logic (at best) gets much more
      -- complicated. (would use dataConIsInfix.)
      use_gadt_syntax :: Bool
use_gadt_syntax = TyCon -> Bool
isGadtSyntaxTyCon TyCon
tc

  consRaw <-
    case     [Either String (GenLocated SrcSpanAnnA (ConDecl GhcRn))]
-> ([String], [GenLocated SrcSpanAnnA (ConDecl GhcRn)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers
         ([Either String (GenLocated SrcSpanAnnA (ConDecl GhcRn))]
 -> ([String], [GenLocated SrcSpanAnnA (ConDecl GhcRn)]))
-> [Either String (GenLocated SrcSpanAnnA (ConDecl GhcRn))]
-> ([String], [GenLocated SrcSpanAnnA (ConDecl GhcRn)])
forall a b. (a -> b) -> a -> b
$   Bool -> DataCon -> Either String (LConDecl GhcRn)
synifyDataCon Bool
use_gadt_syntax
         (DataCon -> Either String (GenLocated SrcSpanAnnA (ConDecl GhcRn)))
-> [DataCon]
-> [Either String (GenLocated SrcSpanAnnA (ConDecl GhcRn))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyCon -> [DataCon]
tyConDataCons TyCon
tc
    of
      ([], [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
cs) -> [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
-> Either String [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
forall a b. b -> Either a b
Right [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
cs
      ([String]
errs, [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
_) -> String -> Either String [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
forall a b. a -> Either a b
Left ([String] -> String
unlines [String]
errs)

  cons <- case (isNewTyCon tc, consRaw) of
      (Bool
False, [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
cons) -> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
-> Either
     String (DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)))
forall a b. b -> Either a b
Right (Bool
-> [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
forall a. Bool -> [a] -> DataDefnCons a
DataTypeCons Bool
False [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
cons)
      (Bool
True, [GenLocated SrcSpanAnnA (ConDecl GhcRn)
con]) -> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
-> Either
     String (DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)))
forall a b. b -> Either a b
Right (GenLocated SrcSpanAnnA (ConDecl GhcRn)
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
forall a. a -> DataDefnCons a
NewTypeCon GenLocated SrcSpanAnnA (ConDecl GhcRn)
con)
      (Bool
True, [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
_) -> String
-> Either
     String (DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)))
forall a b. a -> Either a b
Left String
"Newtype hasn't 1 constructor"

  let -- "deriving" doesn't affect the signature, no need to specify any.
      alg_deriv = []
      defn = HsDataDefn { dd_ext :: XCHsDataDefn GhcRn
dd_ext     = XCHsDataDefn GhcRn
NoExtField
noExtField
                    , dd_ctxt :: Maybe (LHsContext GhcRn)
dd_ctxt    = Maybe (LHsContext GhcRn)
Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
alg_ctx
                    , dd_cType :: Maybe (XRec GhcRn CType)
dd_cType   = Maybe (XRec GhcRn CType)
Maybe (GenLocated SrcSpanAnnP CType)
forall a. Maybe a
Nothing
                    , dd_kindSig :: Maybe (LHsKind GhcRn)
dd_kindSig = Maybe (LHsKind GhcRn)
kindSig
                    , dd_cons :: DataDefnCons (LConDecl GhcRn)
dd_cons    = DataDefnCons (LConDecl GhcRn)
DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
cons
                    , dd_derivs :: HsDeriving GhcRn
dd_derivs  = HsDeriving GhcRn
[GenLocated EpAnnCO (HsDerivingClause GhcRn)]
forall a. [a]
alg_deriv }
  pure  DataDecl { tcdLName = name, tcdTyVars = tyvars
                 , tcdFixity = synifyFixity name
                 , tcdDataDefn = defn
                 , tcdDExt = DataDeclRn False emptyNameSet }

-- | In this module, every TyCon being considered has come from an interface
-- file. This means that when considering a data type constructor such as:
--
-- > data Foo (w :: *) (m :: * -> *) (a :: *)
--
-- Then its tyConKind will be (* -> (* -> *) -> * -> *). But beware! We are
-- also rendering the type variables of Foo, so if we synify the tyConKind of
-- Foo in full, we will end up displaying this in Haddock:
--
-- > data Foo (w :: *) (m :: * -> *) (a :: *)
-- >   :: * -> (* -> *) -> * -> *
--
-- Which is entirely wrong (#548). We only want to display the /return/ kind,
-- which this function obtains.
synifyDataTyConReturnKind :: TyCon -> Maybe (LHsKind GhcRn)
synifyDataTyConReturnKind :: TyCon -> Maybe (LHsKind GhcRn)
synifyDataTyConReturnKind TyCon
tc
  | Type -> Bool
isLiftedTypeKind Type
ret_kind = Maybe (LHsKind GhcRn)
Maybe (GenLocated SrcSpanAnnA (HsType GhcRn))
forall a. Maybe a
Nothing -- Don't bother displaying :: *
  | Bool
otherwise                 = GenLocated SrcSpanAnnA (HsType GhcRn)
-> Maybe (GenLocated SrcSpanAnnA (HsType GhcRn))
forall a. a -> Maybe a
Just (Type -> LHsKind GhcRn
synifyKindSig Type
ret_kind)
  where ret_kind :: Type
ret_kind = TyCon -> Type
tyConResKind TyCon
tc

synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity
                     -> Maybe (LInjectivityAnn GhcRn)
synifyInjectivityAnn :: Maybe Name
-> [TyVar] -> Injectivity -> Maybe (LInjectivityAnn GhcRn)
synifyInjectivityAnn (Just Name
lhs) [TyVar]
tvs (Injective [Bool]
inj) =
    let rhs :: [LocatedN Name]
rhs = (TyVar -> LocatedN Name) -> [TyVar] -> [LocatedN Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> LocatedN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Name -> LocatedN Name)
-> (TyVar -> Name) -> TyVar -> LocatedN Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Name
tyVarName) ([Bool] -> [TyVar] -> [TyVar]
forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
inj [TyVar]
tvs)
    in LInjectivityAnn GhcRn -> Maybe (LInjectivityAnn GhcRn)
forall a. a -> Maybe a
Just (LInjectivityAnn GhcRn -> Maybe (LInjectivityAnn GhcRn))
-> LInjectivityAnn GhcRn -> Maybe (LInjectivityAnn GhcRn)
forall a b. (a -> b) -> a -> b
$ InjectivityAnn GhcRn -> GenLocated EpAnnCO (InjectivityAnn GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (InjectivityAnn GhcRn -> GenLocated EpAnnCO (InjectivityAnn GhcRn))
-> InjectivityAnn GhcRn
-> GenLocated EpAnnCO (InjectivityAnn GhcRn)
forall a b. (a -> b) -> a -> b
$ XCInjectivityAnn GhcRn
-> LIdP GhcRn -> [LIdP GhcRn] -> InjectivityAnn GhcRn
forall pass.
XCInjectivityAnn pass
-> LIdP pass -> [LIdP pass] -> InjectivityAnn pass
InjectivityAnn [AddEpAnn]
XCInjectivityAnn GhcRn
forall a. NoAnn a => a
noAnn (Name -> LocatedN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA Name
lhs) [LIdP GhcRn]
[LocatedN Name]
rhs
synifyInjectivityAnn Maybe Name
_ [TyVar]
_ Injectivity
_ = Maybe (LInjectivityAnn GhcRn)
Maybe (GenLocated EpAnnCO (InjectivityAnn GhcRn))
forall a. Maybe a
Nothing

synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn
synifyFamilyResultSig :: Maybe Name -> Type -> LFamilyResultSig GhcRn
synifyFamilyResultSig Maybe Name
Nothing Type
kind
    | Type -> Bool
isLiftedTypeKind Type
kind
    = FamilyResultSig GhcRn -> GenLocated EpAnnCO (FamilyResultSig GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (FamilyResultSig GhcRn
 -> GenLocated EpAnnCO (FamilyResultSig GhcRn))
-> FamilyResultSig GhcRn
-> GenLocated EpAnnCO (FamilyResultSig GhcRn)
forall a b. (a -> b) -> a -> b
$ XNoSig GhcRn -> FamilyResultSig GhcRn
forall pass. XNoSig pass -> FamilyResultSig pass
NoSig XNoSig GhcRn
NoExtField
noExtField
    | Bool
otherwise
    = FamilyResultSig GhcRn -> GenLocated EpAnnCO (FamilyResultSig GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (FamilyResultSig GhcRn
 -> GenLocated EpAnnCO (FamilyResultSig GhcRn))
-> FamilyResultSig GhcRn
-> GenLocated EpAnnCO (FamilyResultSig GhcRn)
forall a b. (a -> b) -> a -> b
$ XCKindSig GhcRn -> LHsKind GhcRn -> FamilyResultSig GhcRn
forall pass. XCKindSig pass -> LHsKind pass -> FamilyResultSig pass
KindSig XCKindSig GhcRn
NoExtField
noExtField (Type -> LHsKind GhcRn
synifyKindSig Type
kind)
synifyFamilyResultSig (Just Name
name) Type
kind =
    FamilyResultSig GhcRn -> GenLocated EpAnnCO (FamilyResultSig GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (FamilyResultSig GhcRn
 -> GenLocated EpAnnCO (FamilyResultSig GhcRn))
-> FamilyResultSig GhcRn
-> GenLocated EpAnnCO (FamilyResultSig GhcRn)
forall a b. (a -> b) -> a -> b
$ XTyVarSig GhcRn -> LHsTyVarBndr () GhcRn -> FamilyResultSig GhcRn
forall pass.
XTyVarSig pass -> LHsTyVarBndr () pass -> FamilyResultSig pass
TyVarSig XTyVarSig GhcRn
NoExtField
noExtField (HsTyVarBndr () GhcRn
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsTyVarBndr () GhcRn
 -> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn))
-> HsTyVarBndr () GhcRn
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
forall a b. (a -> b) -> a -> b
$ XKindedTyVar GhcRn
-> () -> LIdP GhcRn -> LHsKind GhcRn -> HsTyVarBndr () GhcRn
forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar [AddEpAnn]
XKindedTyVar GhcRn
forall a. NoAnn a => a
noAnn () (Name -> LocatedN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA Name
name) (Type -> LHsKind GhcRn
synifyKindSig Type
kind))

-- User beware: it is your responsibility to pass True (use_gadt_syntax) for any
-- constructor that would be misrepresented by omitting its result-type. But you
-- might want pass False in simple enough cases, if you think it looks better.
synifyDataCon :: Bool -> DataCon -> Either String (LConDecl GhcRn)
synifyDataCon :: Bool -> DataCon -> Either String (LConDecl GhcRn)
synifyDataCon Bool
use_gadt_syntax DataCon
dc =
 let
  -- dataConIsInfix allegedly tells us whether it was declared with
  -- infix *syntax*.
  use_infix_syntax :: Bool
use_infix_syntax = DataCon -> Bool
dataConIsInfix DataCon
dc
  use_named_field_syntax :: Bool
use_named_field_syntax = Bool -> Bool
not ([GenLocated SrcSpanAnnA (ConDeclField GhcRn)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
field_tys)
  name :: LocatedN Name
name = DataCon -> LocatedN Name
forall n. NamedThing n => n -> LocatedN Name
synifyNameN DataCon
dc
  -- con_qvars means a different thing depending on gadt-syntax
  ([TyVar]
_univ_tvs, [TyVar]
ex_tvs, [EqSpec]
_eq_spec, [Type]
theta, [Scaled Type]
arg_tys, Type
res_ty) = DataCon
-> ([TyVar], [TyVar], [EqSpec], [Type], [Scaled Type], Type)
dataConFullSig DataCon
dc
  user_tvbndrs :: [InvisTVBinder]
user_tvbndrs = DataCon -> [InvisTVBinder]
dataConUserTyVarBinders DataCon
dc -- Used for GADT data constructors

  outer_bndrs :: HsOuterTyVarBndrs Specificity GhcRn
outer_bndrs | [InvisTVBinder] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InvisTVBinder]
user_tvbndrs
              = HsOuterImplicit { hso_ximplicit :: XHsOuterImplicit GhcRn
hso_ximplicit = [] }
              | Bool
otherwise
              = HsOuterExplicit { hso_xexplicit :: XHsOuterExplicit GhcRn Specificity
hso_xexplicit = XHsOuterExplicit GhcRn Specificity
NoExtField
noExtField
                                , hso_bndrs :: [LHsTyVarBndr Specificity (NoGhcTc GhcRn)]
hso_bndrs = (InvisTVBinder -> LHsTyVarBndr Specificity (NoGhcTc GhcRn))
-> [InvisTVBinder] -> [LHsTyVarBndr Specificity (NoGhcTc GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map InvisTVBinder -> LHsTyVarBndr Specificity (NoGhcTc GhcRn)
InvisTVBinder -> LHsTyVarBndr Specificity GhcRn
forall flag. VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn
synifyTyVarBndr [InvisTVBinder]
user_tvbndrs }

  -- skip any EqTheta, use 'orig'inal syntax
  ctx :: Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
ctx | [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
theta = Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
forall a. Maybe a
Nothing
      | Bool
otherwise = LHsContext GhcRn -> Maybe (LHsContext GhcRn)
forall a. a -> Maybe a
Just (LHsContext GhcRn -> Maybe (LHsContext GhcRn))
-> LHsContext GhcRn -> Maybe (LHsContext GhcRn)
forall a b. (a -> b) -> a -> b
$ [Type] -> LHsContext GhcRn
synifyCtx [Type]
theta

  linear_tys :: [GenLocated SrcSpanAnnA (HsType GhcRn)]
linear_tys =
    (Scaled Type -> HsSrcBang -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [Scaled Type]
-> [HsSrcBang]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Scaled Type
ty HsSrcBang
bang ->
               let tySyn :: LHsKind GhcRn
tySyn = SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [] (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
ty)
               in case HsSrcBang
bang of
                    (HsSrcBang SourceText
_ SrcUnpackedness
NoSrcUnpack SrcStrictness
NoSrcStrict) -> LHsKind GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
tySyn
                    HsSrcBang
bang' -> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XBangTy GhcRn -> HsSrcBang -> LHsKind GhcRn -> HsType GhcRn
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy [AddEpAnn]
XBangTy GhcRn
forall a. NoAnn a => a
noAnn HsSrcBang
bang' LHsKind GhcRn
tySyn)
            [Scaled Type]
arg_tys (DataCon -> [HsSrcBang]
dataConSrcBangs DataCon
dc)

  field_tys :: [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
field_tys = (FieldLabel
 -> GenLocated SrcSpanAnnA (HsType GhcRn)
 -> GenLocated SrcSpanAnnA (ConDeclField GhcRn))
-> [FieldLabel]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith FieldLabel
-> LHsKind GhcRn -> GenLocated SrcSpanAnnA (ConDeclField GhcRn)
FieldLabel
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> GenLocated SrcSpanAnnA (ConDeclField GhcRn)
forall {pass} {e} {e} {e}.
(XCFieldOcc pass ~ Name,
 XRec pass (FieldOcc pass) ~ GenLocated e (FieldOcc pass),
 XRec pass RdrName ~ GenLocated e RdrName,
 NoAnn (XConDeclField pass), HasAnnotation e, HasAnnotation e,
 HasAnnotation e) =>
FieldLabel
-> XRec pass (BangType pass) -> GenLocated e (ConDeclField pass)
con_decl_field (DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc) [GenLocated SrcSpanAnnA (HsType GhcRn)]
linear_tys
  con_decl_field :: FieldLabel
-> XRec pass (BangType pass) -> GenLocated e (ConDeclField pass)
con_decl_field FieldLabel
fl XRec pass (BangType pass)
synTy = ConDeclField pass -> GenLocated e (ConDeclField pass)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (ConDeclField pass -> GenLocated e (ConDeclField pass))
-> ConDeclField pass -> GenLocated e (ConDeclField pass)
forall a b. (a -> b) -> a -> b
$
    XConDeclField pass
-> [XRec pass (FieldOcc pass)]
-> XRec pass (BangType pass)
-> Maybe (LHsDoc pass)
-> ConDeclField pass
forall pass.
XConDeclField pass
-> [LFieldOcc pass]
-> LBangType pass
-> Maybe (LHsDoc pass)
-> ConDeclField pass
ConDeclField XConDeclField pass
forall a. NoAnn a => a
noAnn [FieldOcc pass -> GenLocated e (FieldOcc pass)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (FieldOcc pass -> GenLocated e (FieldOcc pass))
-> FieldOcc pass -> GenLocated e (FieldOcc pass)
forall a b. (a -> b) -> a -> b
$ XCFieldOcc pass -> XRec pass RdrName -> FieldOcc pass
forall pass. XCFieldOcc pass -> XRec pass RdrName -> FieldOcc pass
FieldOcc (FieldLabel -> Name
flSelector FieldLabel
fl) (RdrName -> GenLocated e RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (RdrName -> GenLocated e RdrName)
-> RdrName -> GenLocated e RdrName
forall a b. (a -> b) -> a -> b
$ FastString -> RdrName
mkVarUnqual (FastString -> RdrName) -> FastString -> RdrName
forall a b. (a -> b) -> a -> b
$ FieldLabelString -> FastString
field_label (FieldLabelString -> FastString) -> FieldLabelString -> FastString
forall a b. (a -> b) -> a -> b
$ FieldLabel -> FieldLabelString
flLabel FieldLabel
fl)] XRec pass (BangType pass)
synTy
                 Maybe (LHsDoc pass)
forall a. Maybe a
Nothing

  mk_h98_arg_tys :: Either String (HsConDeclH98Details GhcRn)
  mk_h98_arg_tys :: Either String (HsConDeclH98Details GhcRn)
mk_h98_arg_tys = case (Bool
use_named_field_syntax, Bool
use_infix_syntax) of
    (Bool
True,Bool
True) -> String
-> Either
     String
     (HsConDetails
        Void
        (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
        (GenLocated
           SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]))
forall a b. a -> Either a b
Left String
"synifyDataCon: contradiction!"
    (Bool
True,Bool
False) -> HsConDeclH98Details GhcRn
-> Either String (HsConDeclH98Details GhcRn)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsConDeclH98Details GhcRn
 -> Either String (HsConDeclH98Details GhcRn))
-> HsConDeclH98Details GhcRn
-> Either String (HsConDeclH98Details GhcRn)
forall a b. (a -> b) -> a -> b
$ GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> HsConDetails
     Void
     (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
     (GenLocated
        SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)])
forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon ([GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> GenLocated
     SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
field_tys)
    (Bool
False,Bool
False) -> HsConDeclH98Details GhcRn
-> Either String (HsConDeclH98Details GhcRn)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsConDeclH98Details GhcRn
 -> Either String (HsConDeclH98Details GhcRn))
-> HsConDeclH98Details GhcRn
-> Either String (HsConDeclH98Details GhcRn)
forall a b. (a -> b) -> a -> b
$ [Void]
-> [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
-> HsConDetails
     Void
     (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
     (GenLocated
        SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)])
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [Void]
noTypeArgs ((GenLocated SrcSpanAnnA (HsType GhcRn)
 -> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall (p :: Pass) a. IsPass p => a -> HsScaled (GhcPass p) a
hsUnrestricted [GenLocated SrcSpanAnnA (HsType GhcRn)]
linear_tys)
    (Bool
False,Bool
True) -> case [GenLocated SrcSpanAnnA (HsType GhcRn)]
linear_tys of
                     [GenLocated SrcSpanAnnA (HsType GhcRn)
a,GenLocated SrcSpanAnnA (HsType GhcRn)
b] -> HsConDeclH98Details GhcRn
-> Either String (HsConDeclH98Details GhcRn)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsConDeclH98Details GhcRn
 -> Either String (HsConDeclH98Details GhcRn))
-> HsConDeclH98Details GhcRn
-> Either String (HsConDeclH98Details GhcRn)
forall a b. (a -> b) -> a -> b
$ HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsConDetails
     Void
     (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
     (GenLocated
        SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)])
forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon (GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall (p :: Pass) a. IsPass p => a -> HsScaled (GhcPass p) a
hsUnrestricted GenLocated SrcSpanAnnA (HsType GhcRn)
a) (GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall (p :: Pass) a. IsPass p => a -> HsScaled (GhcPass p) a
hsUnrestricted GenLocated SrcSpanAnnA (HsType GhcRn)
b)
                     [GenLocated SrcSpanAnnA (HsType GhcRn)]
_ -> String
-> Either
     String
     (HsConDetails
        Void
        (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
        (GenLocated
           SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]))
forall a b. a -> Either a b
Left String
"synifyDataCon: infix with non-2 args?"

  mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn
  mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn
mk_gadt_arg_tys
    | Bool
use_named_field_syntax = XRecConGADT GhcRn
-> XRec GhcRn [LConDeclField GhcRn] -> HsConDeclGADTDetails GhcRn
forall pass.
XRecConGADT pass
-> XRec pass [LConDeclField pass] -> HsConDeclGADTDetails pass
RecConGADT NoExtField
XRecConGADT GhcRn
noExtField ([GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> GenLocated
     SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
field_tys)
    | Bool
otherwise              = XPrefixConGADT GhcRn
-> [HsScaled GhcRn (LHsKind GhcRn)] -> HsConDeclGADTDetails GhcRn
forall pass.
XPrefixConGADT pass
-> [HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
PrefixConGADT NoExtField
XPrefixConGADT GhcRn
noExtField ((GenLocated SrcSpanAnnA (HsType GhcRn)
 -> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall (p :: Pass) a. IsPass p => a -> HsScaled (GhcPass p) a
hsUnrestricted [GenLocated SrcSpanAnnA (HsType GhcRn)]
linear_tys)

 -- finally we get synifyDataCon's result!
 in if Bool
use_gadt_syntax
       then do
         let hat :: HsConDeclGADTDetails GhcRn
hat = HsConDeclGADTDetails GhcRn
mk_gadt_arg_tys
         LConDecl GhcRn -> Either String (LConDecl GhcRn)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (LConDecl GhcRn -> Either String (LConDecl GhcRn))
-> LConDecl GhcRn -> Either String (LConDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ ConDecl GhcRn -> GenLocated SrcSpanAnnA (ConDecl GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (ConDecl GhcRn -> GenLocated SrcSpanAnnA (ConDecl GhcRn))
-> ConDecl GhcRn -> GenLocated SrcSpanAnnA (ConDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ ConDeclGADT
           { con_g_ext :: XConDeclGADT GhcRn
con_g_ext  = XConDeclGADT GhcRn
NoExtField
noExtField
           , con_names :: NonEmpty (LIdP GhcRn)
con_names  = LocatedN Name -> NonEmpty (LocatedN Name)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocatedN Name
name
           , con_bndrs :: XRec GhcRn (HsOuterTyVarBndrs Specificity GhcRn)
con_bndrs  = HsOuterTyVarBndrs Specificity GhcRn
-> GenLocated SrcSpanAnnA (HsOuterTyVarBndrs Specificity GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA HsOuterTyVarBndrs Specificity GhcRn
outer_bndrs
           , con_mb_cxt :: Maybe (LHsContext GhcRn)
con_mb_cxt = Maybe (LHsContext GhcRn)
Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
ctx
           , con_g_args :: HsConDeclGADTDetails GhcRn
con_g_args = HsConDeclGADTDetails GhcRn
hat
           , con_res_ty :: LHsKind GhcRn
con_res_ty = SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [] Type
res_ty
           , con_doc :: Maybe (LHsDoc GhcRn)
con_doc    = Maybe (LHsDoc GhcRn)
forall a. Maybe a
Nothing }
       else do
         hat <- Either String (HsConDeclH98Details GhcRn)
Either
  String
  (HsConDetails
     Void
     (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
     (GenLocated
        SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]))
mk_h98_arg_tys
         return $ noLocA $ ConDeclH98
           { con_ext    = noExtField
           , con_name   = name
           , con_forall = False
           , con_ex_tvs = map (synifyTyVarBndr . (mkForAllTyBinder InferredSpec)) ex_tvs
           , con_mb_cxt = ctx
           , con_args   = hat
           , con_doc    = Nothing }

synifyNameN :: NamedThing n => n -> LocatedN Name
synifyNameN :: forall n. NamedThing n => n -> LocatedN Name
synifyNameN n
n = SrcSpanAnnN -> Name -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan (SrcSpan -> SrcSpanAnnN) -> SrcSpan -> SrcSpanAnnN
forall a b. (a -> b) -> a -> b
$! SrcLoc -> SrcSpan
srcLocSpan (n -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc n
n)) (n -> Name
forall a. NamedThing a => a -> Name
getName n
n)

-- synifyName :: NamedThing n => n -> LocatedA Name
-- synifyName n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n)

-- | Guess the fixity of a something with a name. This isn't quite right, since
-- a user can always declare an infix name in prefix form or a prefix name in
-- infix form. Unfortunately, that is not something we can usually reconstruct.
synifyFixity :: NamedThing n => n -> LexicalFixity
synifyFixity :: forall n. NamedThing n => n -> LexicalFixity
synifyFixity n
n | OccName -> Bool
isSymOcc (n -> OccName
forall a. NamedThing a => a -> OccName
getOccName n
n) = LexicalFixity
Infix
               | Bool
otherwise = LexicalFixity
Prefix

synifyIdSig
  :: PrintRuntimeReps -- ^ are we printing tyvars of kind 'RuntimeRep'?
  -> SynifyTypeState  -- ^ what to do with a 'forall'
  -> [TyVar]          -- ^ free variables in the type to convert
  -> Id               -- ^ the 'Id' from which to get the type signature
  -> Sig GhcRn
synifyIdSig :: PrintRuntimeReps
-> SynifyTypeState -> [TyVar] -> TyVar -> Sig GhcRn
synifyIdSig PrintRuntimeReps
prr SynifyTypeState
s [TyVar]
vs TyVar
i = XTypeSig GhcRn -> [LIdP GhcRn] -> LHsSigWcType GhcRn -> Sig GhcRn
forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig XTypeSig GhcRn
AnnSig
forall a. NoAnn a => a
noAnn [LIdP GhcRn
LocatedN Name
n] (SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn
synifySigWcType SynifyTypeState
s [TyVar]
vs Type
t)
  where
    !n :: LocatedN Name
n = LocatedN Name -> LocatedN Name
forall a. NFData a => a -> a
force (LocatedN Name -> LocatedN Name) -> LocatedN Name -> LocatedN Name
forall a b. (a -> b) -> a -> b
$ TyVar -> LocatedN Name
forall n. NamedThing n => n -> LocatedN Name
synifyNameN TyVar
i
    t :: Type
t = PrintRuntimeReps -> Type -> Type
defaultType PrintRuntimeReps
prr (TyVar -> Type
varType TyVar
i)

-- | Turn a 'ClassOpItem' into a list of signatures. The list returned is going
-- to contain the synified 'ClassOpSig' as well (when appropriate) a default
-- 'ClassOpSig'.
synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn]
synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn]
synifyTcIdSig [TyVar]
vs (TyVar
i, DefMethInfo
dm) =
  [ XClassOpSig GhcRn
-> Bool -> [LIdP GhcRn] -> LHsSigType GhcRn -> Sig GhcRn
forall pass.
XClassOpSig pass
-> Bool -> [LIdP pass] -> LHsSigType pass -> Sig pass
ClassOpSig XClassOpSig GhcRn
AnnSig
forall a. NoAnn a => a
noAnn Bool
False [TyVar -> LocatedN Name
forall n. NamedThing n => n -> LocatedN Name
synifyNameN TyVar
i] (Type -> LHsSigType GhcRn
mainSig (TyVar -> Type
varType TyVar
i)) ] [Sig GhcRn] -> [Sig GhcRn] -> [Sig GhcRn]
forall a. [a] -> [a] -> [a]
++
  [ XClassOpSig GhcRn
-> Bool -> [LIdP GhcRn] -> LHsSigType GhcRn -> Sig GhcRn
forall pass.
XClassOpSig pass
-> Bool -> [LIdP pass] -> LHsSigType pass -> Sig pass
ClassOpSig XClassOpSig GhcRn
AnnSig
forall a. NoAnn a => a
noAnn Bool
True [Name -> LocatedN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA Name
dn] (Type -> LHsSigType GhcRn
defSig Type
dt)
  | Just (Name
dn, GenericDM Type
dt) <- [DefMethInfo
dm] ]
  where
    mainSig :: Type -> LHsSigType GhcRn
mainSig Type
t = SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn
synifySigType SynifyTypeState
DeleteTopLevelQuantification [TyVar]
vs Type
t
    defSig :: Type -> LHsSigType GhcRn
defSig Type
t = SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn
synifySigType SynifyTypeState
ImplicitizeForAll [TyVar]
vs Type
t

synifyCtx :: [PredType] -> LHsContext GhcRn
synifyCtx :: [Type] -> LHsContext GhcRn
synifyCtx [Type]
ts = [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA ((Type -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [Type] -> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType []) [Type]
ts)


synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
synifyTyVars [TyVar]
ktvs = HsQTvs { hsq_ext :: XHsQTvs GhcRn
hsq_ext = []
                           , hsq_explicit :: [LHsTyVarBndr (HsBndrVis GhcRn) GhcRn]
hsq_explicit = (TyVar
 -> GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn))
-> [TyVar]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> LHsTyVarBndr (HsBndrVis GhcRn) GhcRn
TyVar
-> GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcRn) GhcRn)
synifyTyVar [TyVar]
ktvs }

synifyTyVar :: TyVar -> LHsTyVarBndr (HsBndrVis GhcRn) GhcRn
synifyTyVar :: TyVar -> LHsTyVarBndr (HsBndrVis GhcRn) GhcRn
synifyTyVar = VarSet
-> HsBndrVis GhcRn -> TyVar -> LHsTyVarBndr (HsBndrVis GhcRn) GhcRn
forall flag. VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn
synify_ty_var VarSet
emptyVarSet (XBndrRequired GhcRn -> HsBndrVis GhcRn
forall pass. XBndrRequired pass -> HsBndrVis pass
HsBndrRequired NoExtField
XBndrRequired GhcRn
noExtField)

synifyTyVarBndr :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn
synifyTyVarBndr :: forall flag. VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn
synifyTyVarBndr = VarSet -> VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn
forall flag.
VarSet -> VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn
synifyTyVarBndr' VarSet
emptyVarSet

synifyTyVarBndr' :: VarSet -> VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn
synifyTyVarBndr' :: forall flag.
VarSet -> VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn
synifyTyVarBndr' VarSet
no_kinds (Bndr TyVar
tv flag
spec) = VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn
forall flag. VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn
synify_ty_var VarSet
no_kinds flag
spec TyVar
tv

-- | Like 'synifyTyVarBndr', but accepts a set of variables for which to omit kind
-- signatures (even if they don't have the lifted type kind).
synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn
synify_ty_var :: forall flag. VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn
synify_ty_var VarSet
no_kinds flag
flag TyVar
tv
    | Type -> Bool
isLiftedTypeKind Type
kind Bool -> Bool -> Bool
|| TyVar
tv TyVar -> VarSet -> Bool
`elemVarSet` VarSet
no_kinds
    = HsTyVarBndr flag GhcRn
-> GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XUserTyVar GhcRn -> flag -> LIdP GhcRn -> HsTyVarBndr flag GhcRn
forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar [AddEpAnn]
XUserTyVar GhcRn
forall a. NoAnn a => a
noAnn flag
flag (Name -> LocatedN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA Name
name))
    | Bool
otherwise
    = HsTyVarBndr flag GhcRn
-> GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XKindedTyVar GhcRn
-> flag -> LIdP GhcRn -> LHsKind GhcRn -> HsTyVarBndr flag GhcRn
forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar [AddEpAnn]
XKindedTyVar GhcRn
forall a. NoAnn a => a
noAnn flag
flag (Name -> LocatedN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA Name
name) (Type -> LHsKind GhcRn
synifyKindSig Type
kind))
  where
    kind :: Type
kind = TyVar -> Type
tyVarKind TyVar
tv
    name :: Name
name = TyVar -> Name
forall a. NamedThing a => a -> Name
getName TyVar
tv

-- | Annotate (with HsKingSig) a type if the first parameter is True
-- and if the type contains a free variable.
-- This is used to synify type patterns for poly-kinded tyvars in
-- synifying class and type instances.
annotHsType :: Bool   -- True <=> annotate
            -> Type -> LHsType GhcRn -> LHsType GhcRn
  -- tiny optimization: if the type is annotated, don't annotate again.
annotHsType :: Bool -> Type -> LHsKind GhcRn -> LHsKind GhcRn
annotHsType Bool
_    Type
_  hs_ty :: LHsKind GhcRn
hs_ty@(L SrcSpanAnnA
_ (HsKindSig {})) = LHsKind GhcRn
hs_ty
annotHsType Bool
True Type
ty LHsKind GhcRn
hs_ty
  | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ VarSet -> Bool
isEmptyVarSet (VarSet -> Bool) -> VarSet -> Bool
forall a b. (a -> b) -> a -> b
$ (TyVar -> Bool) -> VarSet -> VarSet
filterVarSet TyVar -> Bool
isTyVar (VarSet -> VarSet) -> VarSet -> VarSet
forall a b. (a -> b) -> a -> b
$ Type -> VarSet
tyCoVarsOfType Type
ty
  = let ki :: Type
ki    = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty
        hs_ki :: LHsKind GhcRn
hs_ki = SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [] Type
ki
    in HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XKindSig GhcRn -> LHsKind GhcRn -> LHsKind GhcRn -> HsType GhcRn
forall pass.
XKindSig pass -> LHsType pass -> LHsType pass -> HsType pass
HsKindSig [AddEpAnn]
XKindSig GhcRn
forall a. NoAnn a => a
noAnn LHsKind GhcRn
hs_ty LHsKind GhcRn
hs_ki)
annotHsType Bool
_    Type
_ LHsKind GhcRn
hs_ty = LHsKind GhcRn
hs_ty

-- | For every argument type that a type constructor accepts,
-- report whether or not the argument is poly-kinded. This is used to
-- eventually feed into 'annotThType'.
tyConArgsPolyKinded :: TyCon -> [Bool]
tyConArgsPolyKinded :: TyCon -> [Bool]
tyConArgsPolyKinded TyCon
tc =
     (TyVar -> Bool) -> [TyVar] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Bool
is_poly_ty (Type -> Bool) -> (TyVar -> Type) -> TyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Type
tyVarKind)      [TyVar]
tc_vis_tvs
  [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ (PiTyBinder -> Bool) -> [PiTyBinder] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Bool
is_poly_ty (Type -> Bool) -> (PiTyBinder -> Type) -> PiTyBinder -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PiTyBinder -> Type
piTyBinderType) [PiTyBinder]
tc_res_kind_vis_bndrs
  [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True
  where
    is_poly_ty :: Type -> Bool
    is_poly_ty :: Type -> Bool
is_poly_ty Type
ty = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
                    VarSet -> Bool
isEmptyVarSet (VarSet -> Bool) -> VarSet -> Bool
forall a b. (a -> b) -> a -> b
$
                    (TyVar -> Bool) -> VarSet -> VarSet
filterVarSet TyVar -> Bool
isTyVar (VarSet -> VarSet) -> VarSet -> VarSet
forall a b. (a -> b) -> a -> b
$
                    Type -> VarSet
tyCoVarsOfType Type
ty

    tc_vis_tvs :: [TyVar]
    tc_vis_tvs :: [TyVar]
tc_vis_tvs = TyCon -> [TyVar]
tyConVisibleTyVars TyCon
tc

    tc_res_kind_vis_bndrs :: [PiTyBinder]
    tc_res_kind_vis_bndrs :: [PiTyBinder]
tc_res_kind_vis_bndrs = (PiTyBinder -> Bool) -> [PiTyBinder] -> [PiTyBinder]
forall a. (a -> Bool) -> [a] -> [a]
filter PiTyBinder -> Bool
isVisiblePiTyBinder ([PiTyBinder] -> [PiTyBinder]) -> [PiTyBinder] -> [PiTyBinder]
forall a b. (a -> b) -> a -> b
$ ([PiTyBinder], Type) -> [PiTyBinder]
forall a b. (a, b) -> a
fst (([PiTyBinder], Type) -> [PiTyBinder])
-> ([PiTyBinder], Type) -> [PiTyBinder]
forall a b. (a -> b) -> a -> b
$ Type -> ([PiTyBinder], Type)
splitPiTys (Type -> ([PiTyBinder], Type)) -> Type -> ([PiTyBinder], Type)
forall a b. (a -> b) -> a -> b
$ TyCon -> Type
tyConResKind TyCon
tc

--states of what to do with foralls:
data SynifyTypeState
  = WithinType
  -- ^ normal situation.  This is the safe one to use if you don't
  -- quite understand what's going on.
  | ImplicitizeForAll
  -- ^ beginning of a function definition, in which, to make it look
  --   less ugly, those rank-1 foralls (without kind annotations) are made
  --   implicit.
  | DeleteTopLevelQuantification
  -- ^ because in class methods the context is added to the type
  --   (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@)
  --   which is rather sensible,
  --   but we want to restore things to the source-syntax situation where
  --   the defining class gets to quantify all its functions for free!


synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn
-- The use of mkEmptySigType (which uses empty binders in OuterImplicit)
-- is a bit suspicious; what if the type has free variables?
synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn
synifySigType SynifyTypeState
s [TyVar]
vs Type
ty = LHsKind GhcRn -> LHsSigType GhcRn
mkEmptySigType (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
s [TyVar]
vs Type
ty)

synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn
-- Ditto (see synifySigType)
synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn
synifySigWcType SynifyTypeState
s [TyVar]
vs Type
ty = GenLocated SrcSpanAnnA (HsSigType GhcRn)
-> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
forall thing. thing -> HsWildCardBndrs GhcRn thing
mkEmptyWildCardBndrs (LHsKind GhcRn -> LHsSigType GhcRn
mkEmptySigType ([Name] -> LHsKind GhcRn -> LHsKind GhcRn
rename ((TyVar -> Name) -> [TyVar] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Name
forall a. NamedThing a => a -> Name
getName [TyVar]
vs) (LHsKind GhcRn -> LHsKind GhcRn) -> LHsKind GhcRn -> LHsKind GhcRn
forall a b. (a -> b) -> a -> b
$ SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
s [TyVar]
vs Type
ty))

synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn
-- Ditto (see synifySigType)
synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn
synifyPatSynSigType PatSyn
ps = LHsKind GhcRn -> LHsSigType GhcRn
mkEmptySigType (PatSyn -> LHsKind GhcRn
synifyPatSynType PatSyn
ps)

-- | Depending on the first argument, try to default all type variables of kind
-- 'RuntimeRep' to 'LiftedType'.
defaultType :: PrintRuntimeReps -> Type -> Type
defaultType :: PrintRuntimeReps -> Type -> Type
defaultType PrintRuntimeReps
ShowRuntimeRep = Type -> Type
forall a. a -> a
id
defaultType PrintRuntimeReps
HideRuntimeRep = Type -> Type
defaultRuntimeRepVars

-- | Convert a core type into an 'HsType'.
synifyType
  :: SynifyTypeState  -- ^ what to do with a 'forall'
  -> [TyVar]          -- ^ free variables in the type to convert
  -> Type             -- ^ the type to convert
  -> LHsType GhcRn
synifyType :: SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
_ [TyVar]
_ (TyVarTy TyVar
tv) = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XTyVar GhcRn -> PromotionFlag -> LIdP GhcRn -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar [AddEpAnn]
XTyVar GhcRn
forall a. NoAnn a => a
noAnn PromotionFlag
NotPromoted (LIdP GhcRn -> HsType GhcRn) -> LIdP GhcRn -> HsType GhcRn
forall a b. (a -> b) -> a -> b
$ Name -> LocatedN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (TyVar -> Name
forall a. NamedThing a => a -> Name
getName TyVar
tv)
synifyType SynifyTypeState
_ [TyVar]
vs (TyConApp TyCon
tc [Type]
tys)
  = LHsKind GhcRn -> LHsKind GhcRn
maybe_sig LHsKind GhcRn
res_ty
  where
    res_ty :: LHsType GhcRn
    res_ty :: LHsKind GhcRn
res_ty
      -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)
      | TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tYPETyConKey
      , [TyConApp TyCon
rep [TyConApp TyCon
lev []]] <- [Type]
tys
      , TyCon
rep TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
boxedRepDataConKey
      , TyCon
lev TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
liftedDataConKey
      = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XTyVar GhcRn -> PromotionFlag -> LIdP GhcRn -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar [AddEpAnn]
XTyVar GhcRn
forall a. NoAnn a => a
noAnn PromotionFlag
NotPromoted (Name -> LocatedN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA Name
liftedTypeKindTyConName))

      -- Use non-prefix tuple syntax where possible, because it looks nicer.
      | Just TupleSort
sort <- TyCon -> Maybe TupleSort
tyConTuple_maybe TyCon
tc
      , TyCon -> Arity
tyConArity TyCon
tc Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
tys_len
      = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XTupleTy GhcRn -> HsTupleSort -> [LHsKind GhcRn] -> HsType GhcRn
forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy XTupleTy GhcRn
AnnParen
forall a. NoAnn a => a
noAnn
                          (case TupleSort
sort of
                              TupleSort
BoxedTuple      -> HsTupleSort
HsBoxedOrConstraintTuple
                              TupleSort
ConstraintTuple -> HsTupleSort
HsBoxedOrConstraintTuple
                              TupleSort
UnboxedTuple    -> HsTupleSort
HsUnboxedTuple)
                           ((Type -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [Type] -> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs) [Type]
vis_tys)

      | TyCon -> Bool
isUnboxedSumTyCon TyCon
tc
      = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XSumTy GhcRn -> [LHsKind GhcRn] -> HsType GhcRn
forall pass. XSumTy pass -> [LHsType pass] -> HsType pass
HsSumTy XSumTy GhcRn
AnnParen
forall a. NoAnn a => a
noAnn ((Type -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [Type] -> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs) [Type]
vis_tys)

      | Just DataCon
dc <- TyCon -> Maybe DataCon
isPromotedDataCon_maybe TyCon
tc
      , DataCon -> Bool
isTupleDataCon DataCon
dc
      , DataCon -> Arity
dataConSourceArity DataCon
dc Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== [Type] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
vis_tys
      = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XExplicitTupleTy GhcRn -> [LHsKind GhcRn] -> HsType GhcRn
forall pass. XExplicitTupleTy pass -> [LHsType pass] -> HsType pass
HsExplicitTupleTy XExplicitTupleTy GhcRn
NoExtField
noExtField ((Type -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [Type] -> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs) [Type]
vis_tys)

      -- ditto for lists
      | TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
listTyConName, [Type
ty] <- [Type]
vis_tys
      = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XListTy GhcRn -> LHsKind GhcRn -> HsType GhcRn
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy XListTy GhcRn
AnnParen
forall a. NoAnn a => a
noAnn (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs Type
ty)

      | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
promotedNilDataCon, [] <- [Type]
vis_tys
      = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XExplicitListTy GhcRn
-> PromotionFlag -> [LHsKind GhcRn] -> HsType GhcRn
forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy XExplicitListTy GhcRn
NoExtField
noExtField PromotionFlag
IsPromoted []

      | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
promotedConsDataCon
      , [Type
ty1, Type
ty2] <- [Type]
vis_tys
      = let hTy :: LHsKind GhcRn
hTy = SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs Type
ty1
        in case SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs Type
ty2 of
             LHsKind GhcRn
tTy | L SrcSpanAnnA
_ (HsExplicitListTy XExplicitListTy GhcRn
_ PromotionFlag
IsPromoted [LHsKind GhcRn]
tTy') <- LHsKind GhcRn -> LHsKind GhcRn
stripKindSig LHsKind GhcRn
tTy
                 -> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XExplicitListTy GhcRn
-> PromotionFlag -> [LHsKind GhcRn] -> HsType GhcRn
forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy XExplicitListTy GhcRn
NoExtField
noExtField PromotionFlag
IsPromoted (LHsKind GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
hTy GenLocated SrcSpanAnnA (HsType GhcRn)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a. a -> [a] -> [a]
: [LHsKind GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tTy')
                 | Bool
otherwise
                 -> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XOpTy GhcRn
-> PromotionFlag
-> LHsKind GhcRn
-> LIdP GhcRn
-> LHsKind GhcRn
-> HsType GhcRn
forall pass.
XOpTy pass
-> PromotionFlag
-> LHsType pass
-> LIdP pass
-> LHsType pass
-> HsType pass
HsOpTy [AddEpAnn]
XOpTy GhcRn
forall a. NoAnn a => a
noAnn PromotionFlag
IsPromoted LHsKind GhcRn
hTy (Name -> LocatedN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Name -> LocatedN Name) -> Name -> LocatedN Name
forall a b. (a -> b) -> a -> b
$ TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc) LHsKind GhcRn
tTy

      -- ditto for implicit parameter tycons
      | TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
ipClassKey
      , [Type
name, Type
ty] <- [Type]
tys
      , Just FastString
x <- Type -> Maybe FastString
isStrLitTy Type
name
      = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XIParamTy GhcRn
-> XRec GhcRn HsIPName -> LHsKind GhcRn -> HsType GhcRn
forall pass.
XIParamTy pass -> XRec pass HsIPName -> LHsType pass -> HsType pass
HsIParamTy [AddEpAnn]
XIParamTy GhcRn
forall a. NoAnn a => a
noAnn (HsIPName -> GenLocated EpAnnCO HsIPName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsIPName -> GenLocated EpAnnCO HsIPName)
-> HsIPName -> GenLocated EpAnnCO HsIPName
forall a b. (a -> b) -> a -> b
$ FastString -> HsIPName
HsIPName FastString
x) (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs Type
ty)

      -- and equalities
      | TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqTyConKey
      , [Type
ty1, Type
ty2] <- [Type]
tys
      = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XOpTy GhcRn
-> PromotionFlag
-> LHsKind GhcRn
-> LIdP GhcRn
-> LHsKind GhcRn
-> HsType GhcRn
forall pass.
XOpTy pass
-> PromotionFlag
-> LHsType pass
-> LIdP pass
-> LHsType pass
-> HsType pass
HsOpTy [AddEpAnn]
XOpTy GhcRn
forall a. NoAnn a => a
noAnn
                       PromotionFlag
NotPromoted
                       (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs Type
ty1)
                       (Name -> LocatedN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA Name
eqTyConName)
                       (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs Type
ty2)

      -- and infix type operators
      | OccName -> Bool
isSymOcc (Name -> OccName
nameOccName (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc))
      , Type
ty1:Type
ty2:[Type]
tys_rest <- [Type]
vis_tys
      = HsType GhcRn -> [Type] -> GenLocated SrcSpanAnnA (HsType GhcRn)
mk_app_tys (XOpTy GhcRn
-> PromotionFlag
-> LHsKind GhcRn
-> LIdP GhcRn
-> LHsKind GhcRn
-> HsType GhcRn
forall pass.
XOpTy pass
-> PromotionFlag
-> LHsType pass
-> LIdP pass
-> LHsType pass
-> HsType pass
HsOpTy [AddEpAnn]
XOpTy GhcRn
forall a. NoAnn a => a
noAnn
                           PromotionFlag
prom
                           (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs Type
ty1)
                           (Name -> LocatedN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Name -> LocatedN Name) -> Name -> LocatedN Name
forall a b. (a -> b) -> a -> b
$ TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc)
                           (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs Type
ty2))
                   [Type]
tys_rest

      -- Most TyCons:
      | Bool
otherwise
      = HsType GhcRn -> [Type] -> GenLocated SrcSpanAnnA (HsType GhcRn)
mk_app_tys (XTyVar GhcRn -> PromotionFlag -> LIdP GhcRn -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar [AddEpAnn]
XTyVar GhcRn
forall a. NoAnn a => a
noAnn PromotionFlag
prom (LIdP GhcRn -> HsType GhcRn) -> LIdP GhcRn -> HsType GhcRn
forall a b. (a -> b) -> a -> b
$ Name -> LocatedN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc))
                   [Type]
vis_tys
      where
        !prom :: PromotionFlag
prom = if TyCon -> Bool
isPromotedDataCon TyCon
tc then PromotionFlag
IsPromoted else PromotionFlag
NotPromoted
        mk_app_tys :: HsType GhcRn -> [Type] -> GenLocated SrcSpanAnnA (HsType GhcRn)
mk_app_tys HsType GhcRn
ty_app [Type]
ty_args =
          (GenLocated SrcSpanAnnA (HsType GhcRn)
 -> GenLocated SrcSpanAnnA (HsType GhcRn)
 -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\GenLocated SrcSpanAnnA (HsType GhcRn)
t1 GenLocated SrcSpanAnnA (HsType GhcRn)
t2 -> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XAppTy GhcRn -> LHsKind GhcRn -> LHsKind GhcRn -> HsType GhcRn
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy XAppTy GhcRn
NoExtField
noExtField LHsKind GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
t1 LHsKind GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
t2)
                (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA HsType GhcRn
ty_app)
                ((Type -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [Type] -> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs) ([Type] -> [GenLocated SrcSpanAnnA (HsType GhcRn)])
-> [Type] -> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b. (a -> b) -> a -> b
$
                 (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Type -> Bool
isCoercionTy [Type]
ty_args)

    tys_len :: Arity
tys_len = [Type] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
tys
    vis_tys :: [Type]
vis_tys = TyCon -> [Type] -> [Type]
filterOutInvisibleTypes TyCon
tc [Type]
tys

    maybe_sig :: LHsType GhcRn -> LHsType GhcRn
    maybe_sig :: LHsKind GhcRn -> LHsKind GhcRn
maybe_sig LHsKind GhcRn
ty'
      | Bool -> TyCon -> Arity -> Bool
tyConAppNeedsKindSig Bool
False TyCon
tc Arity
tys_len
      = let full_kind :: Type
full_kind  = HasDebugCallStack => Type -> Type
Type -> Type
typeKind (TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
tys)
            full_kind' :: LHsKind GhcRn
full_kind' = SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs Type
full_kind
        in HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XKindSig GhcRn -> LHsKind GhcRn -> LHsKind GhcRn -> HsType GhcRn
forall pass.
XKindSig pass -> LHsType pass -> LHsType pass -> HsType pass
HsKindSig [AddEpAnn]
XKindSig GhcRn
forall a. NoAnn a => a
noAnn LHsKind GhcRn
ty' LHsKind GhcRn
full_kind'
      | Bool
otherwise = LHsKind GhcRn
ty'

synifyType SynifyTypeState
_ [TyVar]
vs ty :: Type
ty@(AppTy {}) = let
  (Type
ty_head, [Type]
ty_args) = HasDebugCallStack => Type -> (Type, [Type])
Type -> (Type, [Type])
splitAppTys Type
ty
  ty_head' :: LHsKind GhcRn
ty_head' = SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs Type
ty_head
  ty_args' :: [GenLocated SrcSpanAnnA (HsType GhcRn)]
ty_args' = (Type -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [Type] -> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs) ([Type] -> [GenLocated SrcSpanAnnA (HsType GhcRn)])
-> [Type] -> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b. (a -> b) -> a -> b
$
             (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Type -> Bool
isCoercionTy ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$
             [Bool] -> [Type] -> [Type]
forall a. [Bool] -> [a] -> [a]
filterByList ((ForAllTyFlag -> Bool) -> [ForAllTyFlag] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ForAllTyFlag -> Bool
isVisibleForAllTyFlag ([ForAllTyFlag] -> [Bool]) -> [ForAllTyFlag] -> [Bool]
forall a b. (a -> b) -> a -> b
$ Type -> [Type] -> [ForAllTyFlag]
appTyForAllTyFlags Type
ty_head [Type]
ty_args)
                          [Type]
ty_args
  in (GenLocated SrcSpanAnnA (HsType GhcRn)
 -> GenLocated SrcSpanAnnA (HsType GhcRn)
 -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\GenLocated SrcSpanAnnA (HsType GhcRn)
t1 GenLocated SrcSpanAnnA (HsType GhcRn)
t2 -> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XAppTy GhcRn -> LHsKind GhcRn -> LHsKind GhcRn -> HsType GhcRn
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy XAppTy GhcRn
NoExtField
noExtField LHsKind GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
t1 LHsKind GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
t2) LHsKind GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty_head' [GenLocated SrcSpanAnnA (HsType GhcRn)]
ty_args'

synifyType SynifyTypeState
s [TyVar]
vs funty :: Type
funty@(FunTy FunTyFlag
af Type
w Type
t1 Type
t2)
  | FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af = SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifySigmaType SynifyTypeState
s [TyVar]
vs Type
funty
  | Bool
otherwise            = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XFunTy GhcRn
-> HsArrow GhcRn -> LHsKind GhcRn -> LHsKind GhcRn -> HsType GhcRn
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcRn
NoExtField
noExtField HsArrow GhcRn
w' LHsKind GhcRn
s1 LHsKind GhcRn
s2
  where
    s1 :: LHsKind GhcRn
s1 = SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs Type
t1
    s2 :: LHsKind GhcRn
s2 = SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs Type
t2
    w' :: HsArrow GhcRn
w' = [TyVar] -> Type -> HsArrow GhcRn
synifyMult [TyVar]
vs Type
w

synifyType SynifyTypeState
s [TyVar]
vs forallty :: Type
forallty@(ForAllTy (Bndr TyVar
_ ForAllTyFlag
argf) Type
_ty) =
  case ForAllTyFlag
argf of
    ForAllTyFlag
Required    -> [TyVar] -> Type -> LHsKind GhcRn
synifyVisForAllType [TyVar]
vs Type
forallty
    Invisible Specificity
_ -> SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifySigmaType SynifyTypeState
s [TyVar]
vs Type
forallty

synifyType SynifyTypeState
_ [TyVar]
_ (LitTy TyLit
t) = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XTyLit GhcRn -> HsTyLit GhcRn -> HsType GhcRn
forall pass. XTyLit pass -> HsTyLit pass -> HsType pass
HsTyLit XTyLit GhcRn
NoExtField
noExtField (HsTyLit GhcRn -> HsType GhcRn) -> HsTyLit GhcRn -> HsType GhcRn
forall a b. (a -> b) -> a -> b
$ TyLit -> HsTyLit GhcRn
synifyTyLit TyLit
t
synifyType SynifyTypeState
s [TyVar]
vs (CastTy Type
t KindCoercion
_) = SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
s [TyVar]
vs Type
t
synifyType SynifyTypeState
_ [TyVar]
_ (CoercionTy {}) = String -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a. HasCallStack => String -> a
error String
"synifyType:Coercion"

-- | Process a 'Type' which starts with a visible @forall@ into an 'HsType'
synifyVisForAllType
  :: [TyVar]          -- ^ free variables in the type to convert
  -> Type             -- ^ the forall type to convert
  -> LHsType GhcRn
synifyVisForAllType :: [TyVar] -> Type -> LHsKind GhcRn
synifyVisForAllType [TyVar]
vs Type
ty =
  let ([ReqTVBinder]
tvs, Type
rho) = Type -> ([ReqTVBinder], Type)
tcSplitForAllTysReqPreserveSynonyms Type
ty

      sTvs :: [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
sTvs = (ReqTVBinder -> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn))
-> [ReqTVBinder] -> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map ReqTVBinder -> LHsTyVarBndr () GhcRn
ReqTVBinder -> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
forall flag. VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn
synifyTyVarBndr [ReqTVBinder]
tvs

      -- Figure out what the type variable order would be inferred in the
      -- absence of an explicit forall
      tvs' :: [TyVar]
tvs' = VarSet -> [Type] -> [TyVar]
orderedFVs ([TyVar] -> VarSet
mkVarSet [TyVar]
vs) [Type
rho]

  in HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ HsForAllTy { hst_tele :: HsForAllTelescope GhcRn
hst_tele    = EpAnnForallTy -> [LHsTyVarBndr () GhcRn] -> HsForAllTelescope GhcRn
forall (p :: Pass).
EpAnnForallTy
-> [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)
mkHsForAllVisTele EpAnnForallTy
forall a. NoAnn a => a
noAnn [LHsTyVarBndr () GhcRn]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
sTvs
                         , hst_xforall :: XForAllTy GhcRn
hst_xforall = XForAllTy GhcRn
NoExtField
noExtField
                         , hst_body :: LHsKind GhcRn
hst_body    = SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType ([TyVar]
tvs' [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
vs) Type
rho }

-- | Process a 'Type' which starts with an invisible @forall@ or a constraint
-- into an 'HsType'
synifySigmaType
  :: SynifyTypeState  -- ^ what to do with the 'forall'
  -> [TyVar]          -- ^ free variables in the type to convert
  -> Type             -- ^ the forall type to convert
  -> LHsType GhcRn
synifySigmaType :: SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifySigmaType SynifyTypeState
s [TyVar]
vs Type
ty =
  let ([InvisTVBinder]
tvs, [Type]
ctx, Type
tau) = Type -> ([InvisTVBinder], [Type], Type)
tcSplitSigmaTyPreserveSynonyms Type
ty
      sPhi :: HsType GhcRn
sPhi = HsQualTy { hst_ctxt :: LHsContext GhcRn
hst_ctxt = [Type] -> LHsContext GhcRn
synifyCtx [Type]
ctx
                      , hst_xqual :: XQualTy GhcRn
hst_xqual = XQualTy GhcRn
NoExtField
noExtField
                      , hst_body :: LHsKind GhcRn
hst_body = SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType ([TyVar]
tvs' [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
vs) Type
tau }

      sTy :: HsType GhcRn
sTy = HsForAllTy { hst_tele :: HsForAllTelescope GhcRn
hst_tele = EpAnnForallTy
-> [LHsTyVarBndr Specificity GhcRn] -> HsForAllTelescope GhcRn
forall (p :: Pass).
EpAnnForallTy
-> [LHsTyVarBndr Specificity (GhcPass p)]
-> HsForAllTelescope (GhcPass p)
mkHsForAllInvisTele EpAnnForallTy
forall a. NoAnn a => a
noAnn [LHsTyVarBndr Specificity GhcRn]
[GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)]
sTvs
                       , hst_xforall :: XForAllTy GhcRn
hst_xforall = XForAllTy GhcRn
NoExtField
noExtField
                       , hst_body :: LHsKind GhcRn
hst_body  = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA HsType GhcRn
sPhi }

      sTvs :: [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)]
sTvs = (InvisTVBinder
 -> GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn))
-> [InvisTVBinder]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map InvisTVBinder -> LHsTyVarBndr Specificity GhcRn
InvisTVBinder
-> GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)
forall flag. VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn
synifyTyVarBndr [InvisTVBinder]
tvs

      -- Figure out what the type variable order would be inferred in the
      -- absence of an explicit forall
      tvs' :: [TyVar]
tvs' = VarSet -> [Type] -> [TyVar]
orderedFVs ([TyVar] -> VarSet
mkVarSet [TyVar]
vs) ([Type]
ctx [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
tau])

  in case SynifyTypeState
s of
    SynifyTypeState
DeleteTopLevelQuantification -> SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
ImplicitizeForAll ([TyVar]
tvs' [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
vs) Type
tau

    -- Put a forall in if there are any type variables
    SynifyTypeState
WithinType
      | Bool -> Bool
not ([InvisTVBinder] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InvisTVBinder]
tvs) -> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA HsType GhcRn
sTy
      | Bool
otherwise -> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA HsType GhcRn
sPhi

    SynifyTypeState
ImplicitizeForAll -> [TyCon]
-> [TyVar]
-> [InvisTVBinder]
-> [Type]
-> ([TyVar] -> Type -> LHsKind GhcRn)
-> Type
-> LHsKind GhcRn
implicitForAll [] [TyVar]
vs [InvisTVBinder]
tvs [Type]
ctx (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType) Type
tau

-- | Put a forall in if there are any type variables which require
-- explicit kind annotations or if the inferred type variable order
-- would be different.
implicitForAll
  :: [TyCon]          -- ^ type constructors that determine their args kinds
  -> [TyVar]          -- ^ free variables in the type to convert
  -> [InvisTVBinder]  -- ^ type variable binders in the forall
  -> ThetaType        -- ^ constraints right after the forall
  -> ([TyVar] -> Type -> LHsType GhcRn) -- ^ how to convert the inner type
  -> Type             -- ^ inner type
  -> LHsType GhcRn
implicitForAll :: [TyCon]
-> [TyVar]
-> [InvisTVBinder]
-> [Type]
-> ([TyVar] -> Type -> LHsKind GhcRn)
-> Type
-> LHsKind GhcRn
implicitForAll [TyCon]
tycons [TyVar]
vs [InvisTVBinder]
tvs [Type]
ctx [TyVar] -> Type -> LHsKind GhcRn
synInner Type
tau
  | (GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (HsTyVarBndr Specificity GhcRn -> Bool
forall flag pass. HsTyVarBndr flag pass -> Bool
isHsKindedTyVar (HsTyVarBndr Specificity GhcRn -> Bool)
-> (GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)
    -> HsTyVarBndr Specificity GhcRn)
-> GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)
-> HsTyVarBndr Specificity GhcRn
forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)]
sTvs = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA HsType GhcRn
sTy
  | [TyVar]
tvs' [TyVar] -> [TyVar] -> Bool
forall a. Eq a => a -> a -> Bool
/= ([InvisTVBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
tvs)           = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA HsType GhcRn
sTy
  | Bool
otherwise                          = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA HsType GhcRn
sPhi
  where
  sRho :: LHsKind GhcRn
sRho = [TyVar] -> Type -> LHsKind GhcRn
synInner ([TyVar]
tvs' [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
vs) Type
tau
  sPhi :: HsType GhcRn
sPhi | [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
ctx = GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn
forall l e. GenLocated l e -> e
unLoc LHsKind GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
sRho
       | Bool
otherwise
       = HsQualTy { hst_ctxt :: LHsContext GhcRn
hst_ctxt = [Type] -> LHsContext GhcRn
synifyCtx [Type]
ctx
                  , hst_xqual :: XQualTy GhcRn
hst_xqual = XQualTy GhcRn
NoExtField
noExtField
                  , hst_body :: LHsKind GhcRn
hst_body = [TyVar] -> Type -> LHsKind GhcRn
synInner ([TyVar]
tvs' [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
vs) Type
tau }
  sTy :: HsType GhcRn
sTy = HsForAllTy { hst_tele :: HsForAllTelescope GhcRn
hst_tele = EpAnnForallTy
-> [LHsTyVarBndr Specificity GhcRn] -> HsForAllTelescope GhcRn
forall (p :: Pass).
EpAnnForallTy
-> [LHsTyVarBndr Specificity (GhcPass p)]
-> HsForAllTelescope (GhcPass p)
mkHsForAllInvisTele EpAnnForallTy
forall a. NoAnn a => a
noAnn [LHsTyVarBndr Specificity GhcRn]
[GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)]
sTvs
                   , hst_xforall :: XForAllTy GhcRn
hst_xforall = XForAllTy GhcRn
NoExtField
noExtField
                   , hst_body :: LHsKind GhcRn
hst_body = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA HsType GhcRn
sPhi }

  no_kinds_needed :: VarSet
no_kinds_needed = [TyCon] -> Type -> VarSet
noKindTyVars [TyCon]
tycons Type
tau
  sTvs :: [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)]
sTvs = (InvisTVBinder
 -> GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn))
-> [InvisTVBinder]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (VarSet -> InvisTVBinder -> LHsTyVarBndr Specificity GhcRn
forall flag.
VarSet -> VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn
synifyTyVarBndr' VarSet
no_kinds_needed) [InvisTVBinder]
tvs

  -- Figure out what the type variable order would be inferred in the
  -- absence of an explicit forall
  tvs' :: [TyVar]
tvs' = VarSet -> [Type] -> [TyVar]
orderedFVs ([TyVar] -> VarSet
mkVarSet [TyVar]
vs) ([Type]
ctx [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
tau])



-- | Find the set of type variables whose kind signatures can be properly
-- inferred just from their uses in the type signature. This means the type
-- variable to has at least one fully applied use @f x1 x2 ... xn@ where:
--
--   * @f@ has a function kind where the arguments have the same kinds
--     as @x1 x2 ... xn@.
--
--   * @f@ has a function kind whose final return has lifted type kind
--
noKindTyVars
  :: [TyCon]  -- ^ type constructors that determine their args kinds
  -> Type     -- ^ type to inspect
  -> VarSet   -- ^ set of variables whose kinds can be inferred from uses in the type
noKindTyVars :: [TyCon] -> Type -> VarSet
noKindTyVars [TyCon]
_ (TyVarTy TyVar
var)
  | Type -> Bool
isLiftedTypeKind (TyVar -> Type
tyVarKind TyVar
var) = TyVar -> VarSet
unitVarSet TyVar
var
noKindTyVars [TyCon]
ts Type
ty
  | (Type
f, [Type]
xs) <- HasDebugCallStack => Type -> (Type, [Type])
Type -> (Type, [Type])
splitAppTys Type
ty
  , Bool -> Bool
not ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
xs)
  = let args :: [VarSet]
args = (Type -> VarSet) -> [Type] -> [VarSet]
forall a b. (a -> b) -> [a] -> [b]
map ([TyCon] -> Type -> VarSet
noKindTyVars [TyCon]
ts) [Type]
xs
        func :: VarSet
func = case Type
f of
                 TyVarTy TyVar
var | ([Scaled Type]
xsKinds, Type
outKind) <- Type -> ([Scaled Type], Type)
splitFunTys (TyVar -> Type
tyVarKind TyVar
var)
                             , (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
xsKinds [Type] -> [Type] -> Bool
`eqTypes` (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => Type -> Type
Type -> Type
typeKind [Type]
xs
                             , Type -> Bool
isLiftedTypeKind Type
outKind
                             -> TyVar -> VarSet
unitVarSet TyVar
var
                 TyConApp TyCon
t [Type]
ks | TyCon
t TyCon -> [TyCon] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TyCon]
ts
                               , (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
noFreeVarsOfType [Type]
ks
                               -> [TyVar] -> VarSet
mkVarSet [ TyVar
v | TyVarTy TyVar
v <- [Type]
xs ]
                 Type
_ -> [TyCon] -> Type -> VarSet
noKindTyVars [TyCon]
ts Type
f
    in [VarSet] -> VarSet
unionVarSets (VarSet
func VarSet -> [VarSet] -> [VarSet]
forall a. a -> [a] -> [a]
: [VarSet]
args)
noKindTyVars [TyCon]
ts (ForAllTy VarBndr TyVar ForAllTyFlag
_ Type
t) = [TyCon] -> Type -> VarSet
noKindTyVars [TyCon]
ts Type
t
noKindTyVars [TyCon]
ts (FunTy FunTyFlag
_ Type
w Type
t1 Type
t2) = [TyCon] -> Type -> VarSet
noKindTyVars [TyCon]
ts Type
w VarSet -> VarSet -> VarSet
`unionVarSet`
                                    [TyCon] -> Type -> VarSet
noKindTyVars [TyCon]
ts Type
t1 VarSet -> VarSet -> VarSet
`unionVarSet`
                                    [TyCon] -> Type -> VarSet
noKindTyVars [TyCon]
ts Type
t2
noKindTyVars [TyCon]
ts (CastTy Type
t KindCoercion
_) = [TyCon] -> Type -> VarSet
noKindTyVars [TyCon]
ts Type
t
noKindTyVars [TyCon]
_ Type
_ = VarSet
emptyVarSet

synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn
synifyMult :: [TyVar] -> Type -> HsArrow GhcRn
synifyMult [TyVar]
vs Type
t = case Type
t of
                    Type
OneTy  -> XLinearArrow GhcRn -> HsArrow GhcRn
forall pass. XLinearArrow pass -> HsArrow pass
HsLinearArrow NoExtField
XLinearArrow GhcRn
noExtField
                    Type
ManyTy -> XUnrestrictedArrow GhcRn -> HsArrow GhcRn
forall pass. XUnrestrictedArrow pass -> HsArrow pass
HsUnrestrictedArrow NoExtField
XUnrestrictedArrow GhcRn
noExtField
                    Type
ty -> XExplicitMult GhcRn -> LHsKind GhcRn -> HsArrow GhcRn
forall pass. XExplicitMult pass -> LHsType pass -> HsArrow pass
HsExplicitMult NoExtField
XExplicitMult GhcRn
noExtField (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs Type
ty)



synifyPatSynType :: PatSyn -> LHsType GhcRn
synifyPatSynType :: PatSyn -> LHsKind GhcRn
synifyPatSynType PatSyn
ps =
  let ([InvisTVBinder]
univ_tvs, [Type]
req_theta, [InvisTVBinder]
ex_tvs, [Type]
prov_theta, [Scaled Type]
arg_tys, Type
res_ty) = PatSyn
-> ([InvisTVBinder], [Type], [InvisTVBinder], [Type],
    [Scaled Type], Type)
patSynSigBndr PatSyn
ps
      ts :: [TyCon]
ts = Maybe TyCon -> [TyCon]
forall a. Maybe a -> [a]
maybeToList (Type -> Maybe TyCon
tyConAppTyCon_maybe Type
res_ty)

      -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>",
      -- i.e., an explicit empty context, which is what we need. This is not
      -- possible by taking theta = [], as that will print no context at all
      req_theta' :: [Type]
req_theta' | [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
req_theta
                 , Bool -> Bool
not ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
prov_theta Bool -> Bool -> Bool
&& [InvisTVBinder] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InvisTVBinder]
ex_tvs)
                 = [Type
unitTy]
                 | Bool
otherwise = [Type]
req_theta

  in [TyCon]
-> [TyVar]
-> [InvisTVBinder]
-> [Type]
-> ([TyVar] -> Type -> LHsKind GhcRn)
-> Type
-> LHsKind GhcRn
implicitForAll [TyCon]
ts [] ([InvisTVBinder]
univ_tvs [InvisTVBinder] -> [InvisTVBinder] -> [InvisTVBinder]
forall a. [a] -> [a] -> [a]
++ [InvisTVBinder]
ex_tvs) [Type]
req_theta'
       (\[TyVar]
vs -> [TyCon]
-> [TyVar]
-> [InvisTVBinder]
-> [Type]
-> ([TyVar] -> Type -> LHsKind GhcRn)
-> Type
-> LHsKind GhcRn
implicitForAll [TyCon]
ts [TyVar]
vs [] [Type]
prov_theta (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType))
       ([Scaled Type] -> Type -> Type
HasDebugCallStack => [Scaled Type] -> Type -> Type
mkScaledFunTys [Scaled Type]
arg_tys Type
res_ty)

synifyTyLit :: TyLit -> HsTyLit GhcRn
synifyTyLit :: TyLit -> HsTyLit GhcRn
synifyTyLit (NumTyLit Integer
n) = XNumTy GhcRn -> Integer -> HsTyLit GhcRn
forall pass. XNumTy pass -> Integer -> HsTyLit pass
HsNumTy XNumTy GhcRn
SourceText
NoSourceText Integer
n
synifyTyLit (StrTyLit FastString
s) = XStrTy GhcRn -> FastString -> HsTyLit GhcRn
forall pass. XStrTy pass -> FastString -> HsTyLit pass
HsStrTy XStrTy GhcRn
SourceText
NoSourceText FastString
s
synifyTyLit (CharTyLit Char
c) = XCharTy GhcRn -> Char -> HsTyLit GhcRn
forall pass. XCharTy pass -> Char -> HsTyLit pass
HsCharTy XCharTy GhcRn
SourceText
NoSourceText Char
c

synifyKindSig :: Kind -> LHsKind GhcRn
synifyKindSig :: Type -> LHsKind GhcRn
synifyKindSig Type
k = SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [] Type
k

stripKindSig :: LHsType GhcRn -> LHsType GhcRn
stripKindSig :: LHsKind GhcRn -> LHsKind GhcRn
stripKindSig (L SrcSpanAnnA
_ (HsKindSig XKindSig GhcRn
_ LHsKind GhcRn
t LHsKind GhcRn
_)) = LHsKind GhcRn
t
stripKindSig LHsKind GhcRn
t = LHsKind GhcRn
t

synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> [(FamInst, Bool, Maybe (MDoc Name), Located Name, Maybe Module)] -> InstHead GhcRn
synifyInstHead :: ([TyVar], [Type], Class, [Type])
-> [(FamInst, Bool, Maybe (MDoc Name), Located Name, Maybe Module)]
-> InstHead GhcRn
synifyInstHead ([TyVar]
vs, [Type]
preds, Class
cls, [Type]
types) [(FamInst, Bool, Maybe (MDoc Name), Located Name, Maybe Module)]
associated_families = InstHead
    { ihdClsName :: IdP GhcRn
ihdClsName = Class -> Name
forall a. NamedThing a => a -> Name
getName Class
cls
    , ihdTypes :: [HsType GhcRn]
ihdTypes = (GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> [HsType GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn
forall l e. GenLocated l e -> e
unLoc [GenLocated SrcSpanAnnA (HsType GhcRn)]
annot_ts
    , ihdInstType :: InstType GhcRn
ihdInstType = ClassInst
        { clsiCtx :: [HsType GhcRn]
clsiCtx = (Type -> HsType GhcRn) -> [Type] -> [HsType GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn)
-> (Type -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> Type
-> HsType GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType []) [Type]
preds
        , clsiTyVars :: LHsQTyVars GhcRn
clsiTyVars = [TyVar] -> LHsQTyVars GhcRn
synifyTyVars (TyCon -> [TyVar]
tyConVisibleTyVars TyCon
cls_tycon)
        , clsiSigs :: [Sig GhcRn]
clsiSigs = (TyVar -> Sig GhcRn) -> [TyVar] -> [Sig GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Sig GhcRn
synifyClsIdSig ([TyVar] -> [Sig GhcRn]) -> [TyVar] -> [Sig GhcRn]
forall a b. (a -> b) -> a -> b
$ [TyVar]
specialized_class_methods
        , clsiAssocTys :: [DocInstance GhcRn]
clsiAssocTys = [ (InstHead GhcRn
f_inst, Maybe (MetaDoc (Wrap (ModuleName, OccName)) (Wrap (IdP GhcRn)))
Maybe (MDoc Name)
f_doc, GenLocated SrcSpan (IdP GhcRn)
Located Name
f_name, Maybe Module
f_mod)
                         | (FamInst
f_i, Bool
opaque, Maybe (MDoc Name)
f_doc, Located Name
f_name, Maybe Module
f_mod) <- [(FamInst, Bool, Maybe (MDoc Name), Located Name, Maybe Module)]
associated_families
                         , Right InstHead GhcRn
f_inst <- [FamInst -> Bool -> Either String (InstHead GhcRn)
synifyFamInst FamInst
f_i Bool
opaque]
                         ]
        }
    }
  where
    cls_tycon :: TyCon
cls_tycon = Class -> TyCon
classTyCon Class
cls
    ts :: [Type]
ts  = TyCon -> [Type] -> [Type]
filterOutInvisibleTypes TyCon
cls_tycon [Type]
types
    ts' :: [GenLocated SrcSpanAnnA (HsType GhcRn)]
ts' = (Type -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [Type] -> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [TyVar]
vs) [Type]
ts
    annot_ts :: [GenLocated SrcSpanAnnA (HsType GhcRn)]
annot_ts = (Bool
 -> Type
 -> GenLocated SrcSpanAnnA (HsType GhcRn)
 -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [Bool]
-> [Type]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Bool -> Type -> LHsKind GhcRn -> LHsKind GhcRn
Bool
-> Type
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn)
annotHsType [Bool]
args_poly [Type]
ts [GenLocated SrcSpanAnnA (HsType GhcRn)]
ts'
    args_poly :: [Bool]
args_poly = TyCon -> [Bool]
tyConArgsPolyKinded TyCon
cls_tycon
    synifyClsIdSig :: TyVar -> Sig GhcRn
synifyClsIdSig = PrintRuntimeReps
-> SynifyTypeState -> [TyVar] -> TyVar -> Sig GhcRn
synifyIdSig PrintRuntimeReps
ShowRuntimeRep SynifyTypeState
DeleteTopLevelQuantification [TyVar]
vs
    specialized_class_methods :: [TyVar]
specialized_class_methods = [ TyVar -> Type -> TyVar
setIdType TyVar
m (HasDebugCallStack => Type -> [Type] -> Type
Type -> [Type] -> Type
piResultTys (TyVar -> Type
idType TyVar
m) [Type]
types) | TyVar
m <- Class -> [TyVar]
classMethods Class
cls ]

-- Convert a family instance, this could be a type family or data family
synifyFamInst :: FamInst -> Bool -> Either String (InstHead GhcRn)
synifyFamInst :: FamInst -> Bool -> Either String (InstHead GhcRn)
synifyFamInst FamInst
fi Bool
opaque = do
    ityp' <- FamFlavor -> Either String (InstType GhcRn)
ityp FamFlavor
fam_flavor
    return InstHead
        { ihdClsName = fi_fam fi
        , ihdTypes = map unLoc annot_ts
        , ihdInstType = ityp'
        }
  where
    ityp :: FamFlavor -> Either String (InstType GhcRn)
ityp FamFlavor
SynFamilyInst | Bool
opaque = InstType GhcRn -> Either String (InstType GhcRn)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstType GhcRn -> Either String (InstType GhcRn))
-> InstType GhcRn -> Either String (InstType GhcRn)
forall a b. (a -> b) -> a -> b
$ Maybe (HsType GhcRn) -> InstType GhcRn
forall name. Maybe (HsType name) -> InstType name
TypeInst Maybe (HsType GhcRn)
forall a. Maybe a
Nothing
    ityp FamFlavor
SynFamilyInst =
        InstType GhcRn -> Either String (InstType GhcRn)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstType GhcRn -> Either String (InstType GhcRn))
-> (LHsKind GhcRn -> InstType GhcRn)
-> LHsKind GhcRn
-> Either String (InstType GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (HsType GhcRn) -> InstType GhcRn
forall name. Maybe (HsType name) -> InstType name
TypeInst (Maybe (HsType GhcRn) -> InstType GhcRn)
-> (GenLocated SrcSpanAnnA (HsType GhcRn) -> Maybe (HsType GhcRn))
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> InstType GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType GhcRn -> Maybe (HsType GhcRn)
forall a. a -> Maybe a
Just (HsType GhcRn -> Maybe (HsType GhcRn))
-> (GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> Maybe (HsType GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn
forall l e. GenLocated l e -> e
unLoc (LHsKind GhcRn -> Either String (InstType GhcRn))
-> LHsKind GhcRn -> Either String (InstType GhcRn)
forall a b. (a -> b) -> a -> b
$ SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [] Type
fam_rhs
    ityp (DataFamilyInst TyCon
c) =
        TyClDecl GhcRn -> InstType GhcRn
forall name. TyClDecl name -> InstType name
DataInst (TyClDecl GhcRn -> InstType GhcRn)
-> Either String (TyClDecl GhcRn) -> Either String (InstType GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrintRuntimeReps
-> Maybe (CoAxiom Unbranched)
-> TyCon
-> Either String (TyClDecl GhcRn)
forall (br :: BranchFlag).
PrintRuntimeReps
-> Maybe (CoAxiom br) -> TyCon -> Either String (TyClDecl GhcRn)
synifyTyCon PrintRuntimeReps
HideRuntimeRep (CoAxiom Unbranched -> Maybe (CoAxiom Unbranched)
forall a. a -> Maybe a
Just (CoAxiom Unbranched -> Maybe (CoAxiom Unbranched))
-> CoAxiom Unbranched -> Maybe (CoAxiom Unbranched)
forall a b. (a -> b) -> a -> b
$ FamInst -> CoAxiom Unbranched
famInstAxiom FamInst
fi) TyCon
c
    fam_tc :: TyCon
fam_tc     = FamInst -> TyCon
famInstTyCon FamInst
fi
    fam_flavor :: FamFlavor
fam_flavor = FamInst -> FamFlavor
fi_flavor FamInst
fi
    fam_lhs :: [Type]
fam_lhs    = FamInst -> [Type]
fi_tys FamInst
fi
    fam_rhs :: Type
fam_rhs    = FamInst -> Type
fi_rhs FamInst
fi

    eta_expanded_lhs :: [Type]
eta_expanded_lhs
      -- eta-expand lhs types, because sometimes data/newtype
      -- instances are eta-reduced; See Trac #9692
      -- See Note [Eta reduction for data family axioms] in GHC.Tc.TyCl.Instance in GHC
      | DataFamilyInst TyCon
rep_tc <- FamFlavor
fam_flavor
      = let (TyCon
_, [Type]
rep_tc_args) = Type -> (TyCon, [Type])
splitTyConApp Type
fam_rhs
            etad_tyvars :: [TyVar]
etad_tyvars      = [Type] -> [TyVar] -> [TyVar]
forall b a. [b] -> [a] -> [a]
dropList [Type]
rep_tc_args ([TyVar] -> [TyVar]) -> [TyVar] -> [TyVar]
forall a b. (a -> b) -> a -> b
$ TyCon -> [TyVar]
tyConTyVars TyCon
rep_tc
            etad_tys :: [Type]
etad_tys         = [TyVar] -> [Type]
mkTyVarTys [TyVar]
etad_tyvars
            eta_exp_lhs :: [Type]
eta_exp_lhs      = [Type]
fam_lhs [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
`chkAppend` [Type]
etad_tys
        in [Type]
eta_exp_lhs
      | Bool
otherwise
      = [Type]
fam_lhs

    ts :: [Type]
ts = TyCon -> [Type] -> [Type]
filterOutInvisibleTypes TyCon
fam_tc [Type]
eta_expanded_lhs
    synifyTypes :: [Type] -> [GenLocated SrcSpanAnnA (HsType GhcRn)]
synifyTypes = (Type -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [Type] -> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (SynifyTypeState -> [TyVar] -> Type -> LHsKind GhcRn
synifyType SynifyTypeState
WithinType [])
    ts' :: [GenLocated SrcSpanAnnA (HsType GhcRn)]
ts' = [Type] -> [GenLocated SrcSpanAnnA (HsType GhcRn)]
synifyTypes [Type]
ts
    annot_ts :: [GenLocated SrcSpanAnnA (HsType GhcRn)]
annot_ts = (Bool
 -> Type
 -> GenLocated SrcSpanAnnA (HsType GhcRn)
 -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [Bool]
-> [Type]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Bool -> Type -> LHsKind GhcRn -> LHsKind GhcRn
Bool
-> Type
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn)
annotHsType [Bool]
args_poly [Type]
ts [GenLocated SrcSpanAnnA (HsType GhcRn)]
ts'
    args_poly :: [Bool]
args_poly = TyCon -> [Bool]
tyConArgsPolyKinded TyCon
fam_tc

{-
Note [Invariant: Never expand type synonyms]

In haddock, we never want to expand a type synonym that may be presented to the
user, as we want to keep the link to the abstraction captured in the synonym.

All code in Haddock.Convert must make sure that this invariant holds.

See https://github.com/haskell/haddock/issues/879 for a bug where this
invariant didn't hold.
-}

-- | A version of 'TcType.tcSplitSigmaTy' that:
--
-- 1. Preserves type synonyms.
-- 2. Returns 'InvisTVBinder's instead of 'TyVar's.
--
-- See Note [Invariant: Never expand type synonyms]
tcSplitSigmaTyPreserveSynonyms :: Type -> ([InvisTVBinder], ThetaType, Type)
tcSplitSigmaTyPreserveSynonyms :: Type -> ([InvisTVBinder], [Type], Type)
tcSplitSigmaTyPreserveSynonyms Type
ty =
    case Type -> ([InvisTVBinder], Type)
tcSplitForAllTysInvisPreserveSynonyms Type
ty of
      ([InvisTVBinder]
tvs, Type
rho) -> case Type -> ([Type], Type)
tcSplitPhiTyPreserveSynonyms Type
rho of
        ([Type]
theta, Type
tau) -> ([InvisTVBinder]
tvs, [Type]
theta, Type
tau)

-- | See Note [Invariant: Never expand type synonyms]
tcSplitSomeForAllTysPreserveSynonyms ::
  (ForAllTyFlag -> Bool) -> Type -> ([ForAllTyBinder], Type)
tcSplitSomeForAllTysPreserveSynonyms :: (ForAllTyFlag -> Bool)
-> Type -> ([VarBndr TyVar ForAllTyFlag], Type)
tcSplitSomeForAllTysPreserveSynonyms ForAllTyFlag -> Bool
argf_pred Type
ty = Type
-> Type
-> [VarBndr TyVar ForAllTyFlag]
-> ([VarBndr TyVar ForAllTyFlag], Type)
split Type
ty Type
ty []
  where
    split :: Type
-> Type
-> [VarBndr TyVar ForAllTyFlag]
-> ([VarBndr TyVar ForAllTyFlag], Type)
split Type
_ (ForAllTy tvb :: VarBndr TyVar ForAllTyFlag
tvb@(Bndr TyVar
_ ForAllTyFlag
argf) Type
ty') [VarBndr TyVar ForAllTyFlag]
tvs
      | ForAllTyFlag -> Bool
argf_pred ForAllTyFlag
argf  = Type
-> Type
-> [VarBndr TyVar ForAllTyFlag]
-> ([VarBndr TyVar ForAllTyFlag], Type)
split Type
ty' Type
ty' (VarBndr TyVar ForAllTyFlag
tvbVarBndr TyVar ForAllTyFlag
-> [VarBndr TyVar ForAllTyFlag] -> [VarBndr TyVar ForAllTyFlag]
forall a. a -> [a] -> [a]
:[VarBndr TyVar ForAllTyFlag]
tvs)
    split Type
orig_ty Type
_ [VarBndr TyVar ForAllTyFlag]
tvs = ([VarBndr TyVar ForAllTyFlag] -> [VarBndr TyVar ForAllTyFlag]
forall a. [a] -> [a]
reverse [VarBndr TyVar ForAllTyFlag]
tvs, Type
orig_ty)

-- | See Note [Invariant: Never expand type synonyms]
tcSplitForAllTysReqPreserveSynonyms :: Type -> ([ReqTVBinder], Type)
tcSplitForAllTysReqPreserveSynonyms :: Type -> ([ReqTVBinder], Type)
tcSplitForAllTysReqPreserveSynonyms Type
ty =
  let ([VarBndr TyVar ForAllTyFlag]
all_bndrs, Type
body) = (ForAllTyFlag -> Bool)
-> Type -> ([VarBndr TyVar ForAllTyFlag], Type)
tcSplitSomeForAllTysPreserveSynonyms ForAllTyFlag -> Bool
isVisibleForAllTyFlag Type
ty
      req_bndrs :: [ReqTVBinder]
req_bndrs         = (VarBndr TyVar ForAllTyFlag -> Maybe ReqTVBinder)
-> [VarBndr TyVar ForAllTyFlag] -> [ReqTVBinder]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VarBndr TyVar ForAllTyFlag -> Maybe ReqTVBinder
mk_req_bndr_maybe [VarBndr TyVar ForAllTyFlag]
all_bndrs in
  Bool -> ([ReqTVBinder], Type) -> ([ReqTVBinder], Type)
forall a. HasCallStack => Bool -> a -> a
assert ( [ReqTVBinder]
req_bndrs [ReqTVBinder] -> [VarBndr TyVar ForAllTyFlag] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [VarBndr TyVar ForAllTyFlag]
all_bndrs)
    ([ReqTVBinder]
req_bndrs, Type
body)
  where
    mk_req_bndr_maybe :: ForAllTyBinder -> Maybe ReqTVBinder
    mk_req_bndr_maybe :: VarBndr TyVar ForAllTyFlag -> Maybe ReqTVBinder
mk_req_bndr_maybe (Bndr TyVar
tv ForAllTyFlag
argf) = case ForAllTyFlag
argf of
      ForAllTyFlag
Required    -> ReqTVBinder -> Maybe ReqTVBinder
forall a. a -> Maybe a
Just (ReqTVBinder -> Maybe ReqTVBinder)
-> ReqTVBinder -> Maybe ReqTVBinder
forall a b. (a -> b) -> a -> b
$ TyVar -> () -> ReqTVBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv ()
      Invisible Specificity
_ -> Maybe ReqTVBinder
forall a. Maybe a
Nothing

-- | See Note [Invariant: Never expand type synonyms]
tcSplitForAllTysInvisPreserveSynonyms :: Type -> ([InvisTVBinder], Type)
tcSplitForAllTysInvisPreserveSynonyms :: Type -> ([InvisTVBinder], Type)
tcSplitForAllTysInvisPreserveSynonyms Type
ty =
  let ([VarBndr TyVar ForAllTyFlag]
all_bndrs, Type
body) = (ForAllTyFlag -> Bool)
-> Type -> ([VarBndr TyVar ForAllTyFlag], Type)
tcSplitSomeForAllTysPreserveSynonyms ForAllTyFlag -> Bool
isInvisibleForAllTyFlag Type
ty
      inv_bndrs :: [InvisTVBinder]
inv_bndrs         = (VarBndr TyVar ForAllTyFlag -> Maybe InvisTVBinder)
-> [VarBndr TyVar ForAllTyFlag] -> [InvisTVBinder]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VarBndr TyVar ForAllTyFlag -> Maybe InvisTVBinder
mk_inv_bndr_maybe [VarBndr TyVar ForAllTyFlag]
all_bndrs in
  Bool -> ([InvisTVBinder], Type) -> ([InvisTVBinder], Type)
forall a. HasCallStack => Bool -> a -> a
assert ( [InvisTVBinder]
inv_bndrs [InvisTVBinder] -> [VarBndr TyVar ForAllTyFlag] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [VarBndr TyVar ForAllTyFlag]
all_bndrs)
    ([InvisTVBinder]
inv_bndrs, Type
body)
  where
    mk_inv_bndr_maybe :: ForAllTyBinder -> Maybe InvisTVBinder
    mk_inv_bndr_maybe :: VarBndr TyVar ForAllTyFlag -> Maybe InvisTVBinder
mk_inv_bndr_maybe (Bndr TyVar
tv ForAllTyFlag
argf) = case ForAllTyFlag
argf of
      Invisible Specificity
s -> InvisTVBinder -> Maybe InvisTVBinder
forall a. a -> Maybe a
Just (InvisTVBinder -> Maybe InvisTVBinder)
-> InvisTVBinder -> Maybe InvisTVBinder
forall a b. (a -> b) -> a -> b
$ TyVar -> Specificity -> InvisTVBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv Specificity
s
      ForAllTyFlag
Required    -> Maybe InvisTVBinder
forall a. Maybe a
Nothing

-- | See Note [Invariant: Never expand type synonyms]

-- | See Note [Invariant: Never expand type synonyms]
tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type)
tcSplitPhiTyPreserveSynonyms :: Type -> ([Type], Type)
tcSplitPhiTyPreserveSynonyms Type
ty0 = Type -> [Type] -> ([Type], Type)
split Type
ty0 []
  where
    split :: Type -> [Type] -> ([Type], Type)
split Type
ty [Type]
ts
      = case Type -> Maybe (Type, Type)
tcSplitPredFunTyPreserveSynonyms_maybe Type
ty of
          Just (Type
pred_, Type
ty') -> Type -> [Type] -> ([Type], Type)
split Type
ty' (Type
pred_Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
ts)
          Maybe (Type, Type)
Nothing           -> ([Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
ts, Type
ty)

-- | See Note [Invariant: Never expand type synonyms]
tcSplitPredFunTyPreserveSynonyms_maybe :: Type -> Maybe (PredType, Type)
tcSplitPredFunTyPreserveSynonyms_maybe :: Type -> Maybe (Type, Type)
tcSplitPredFunTyPreserveSynonyms_maybe (FunTy FunTyFlag
af Type
_ Type
arg Type
res)
  | FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af = (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (Type
arg, Type
res)
tcSplitPredFunTyPreserveSynonyms_maybe Type
_ = Maybe (Type, Type)
forall a. Maybe a
Nothing