{-# LANGUAGE CPP, PatternGuards, TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
-- 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 Bag ( emptyBag )
import BasicTypes ( TupleSort(..), SourceText(..), LexicalFixity(..)
                  , PromotionFlag(..), DefMethSpec(..) )
import Class
import CoAxiom
import ConLike
import Data.Either (lefts, rights)
import DataCon
import FamInstEnv
import GHC.Hs
import Name
import NameSet ( emptyNameSet )
import RdrName ( mkVarUnqual )
import PatSyn
import SrcLoc ( Located, noLoc, unLoc, GenLocated(..), srcLocSpan )
import TcType
import TyCon
import Type
import TyCoRep
import TysPrim ( alphaTyVars )
import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName
                  , unitTy, promotedNilDataCon, promotedConsDataCon )
import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey
                 , liftedRepDataConKey )
import Unique ( getUnique )
import Util ( chkAppend, dropList, filterByList, filterOut )
import Var
import VarSet

import Haddock.Types
import Haddock.Interface.Specialize
import Haddock.GhcUtils                      ( orderedFVs, defaultRuntimeRepVars )

import Data.Maybe                            ( catMaybes, maybeToList )


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

-- the main function here! yay!
tyThingToLHsDecl
  :: PrintRuntimeReps
  -> TyThing
  -> Either ErrMsg ([ErrMsg], (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 Id
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 NoExtField
XSigD GhcRn
noExtField (PrintRuntimeReps -> SynifyTypeState -> [Id] -> Id -> Sig GhcRn
synifyIdSig PrintRuntimeReps
prr SynifyTypeState
ImplicitizeForAll [] Id
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 ErrMsg (FamilyDecl a)
           extractFamilyDecl :: TyClDecl a -> Either String (FamilyDecl a)
extractFamilyDecl (FamDecl XFamDecl a
_ FamilyDecl a
d) = FamilyDecl a -> Either String (FamilyDecl 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"

           extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn
           extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn
extractFamDefDecl FamilyDecl GhcRn
fd Type
rhs =
             TyFamInstEqn GhcRn -> TyFamDefltDecl GhcRn
forall pass. TyFamInstEqn pass -> TyFamInstDecl pass
TyFamInstDecl (TyFamInstEqn GhcRn -> TyFamDefltDecl GhcRn)
-> TyFamInstEqn GhcRn -> TyFamDefltDecl GhcRn
forall a b. (a -> b) -> a -> b
$ HsIB :: forall pass thing.
XHsIB pass thing -> thing -> HsImplicitBndrs pass thing
HsIB { hsib_ext :: XHsIB GhcRn (FamEqn GhcRn (LHsType GhcRn))
hsib_ext = 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)
                                  , hsib_body :: FamEqn GhcRn (LHsType GhcRn)
hsib_body = FamEqn :: forall pass rhs.
XCFamEqn pass rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr pass]
-> HsTyPats pass
-> LexicalFixity
-> rhs
-> FamEqn pass rhs
FamEqn
             { feqn_ext :: XCFamEqn GhcRn (LHsType GhcRn)
feqn_ext = NoExtField
XCFamEqn GhcRn (LHsType GhcRn)
noExtField
             , feqn_tycon :: Located (IdP GhcRn)
feqn_tycon = FamilyDecl GhcRn -> Located (IdP GhcRn)
forall pass. FamilyDecl pass -> Located (IdP pass)
fdLName FamilyDecl GhcRn
fd
             , feqn_bndrs :: Maybe [LHsTyVarBndr GhcRn]
feqn_bndrs = Maybe [LHsTyVarBndr GhcRn]
forall a. Maybe a
Nothing
             , feqn_pats :: HsTyPats GhcRn
feqn_pats = (LHsTyVarBndr GhcRn -> HsArg (LHsType GhcRn) (LHsType GhcRn))
-> [LHsTyVarBndr GhcRn] -> HsTyPats GhcRn
forall a b. (a -> b) -> [a] -> [b]
map (LHsType GhcRn -> HsArg (LHsType GhcRn) (LHsType GhcRn)
forall tm ty. tm -> HsArg tm ty
HsValArg (LHsType GhcRn -> HsArg (LHsType GhcRn) (LHsType GhcRn))
-> (LHsTyVarBndr GhcRn -> LHsType GhcRn)
-> LHsTyVarBndr GhcRn
-> HsArg (LHsType GhcRn) (LHsType GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsTyVarBndr GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p)
hsLTyVarBndrToType) ([LHsTyVarBndr GhcRn] -> HsTyPats GhcRn)
-> [LHsTyVarBndr GhcRn] -> HsTyPats GhcRn
forall a b. (a -> b) -> a -> b
$
                           LHsQTyVars GhcRn -> [LHsTyVarBndr GhcRn]
forall pass. LHsQTyVars pass -> [LHsTyVarBndr pass]
hsq_explicit (LHsQTyVars GhcRn -> [LHsTyVarBndr GhcRn])
-> LHsQTyVars GhcRn -> [LHsTyVarBndr 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 :: LHsType GhcRn
feqn_rhs = SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [] Type
rhs }}

           extractAtItem
             :: ClassATItem
             -> Either ErrMsg (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))
           extractAtItem :: ClassATItem
-> Either String (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))
extractAtItem (ATI TyCon
at_tc Maybe (Type, SrcSpan)
def) = do
             TyClDecl GhcRn
tyDecl <- PrintRuntimeReps
-> Maybe (CoAxiom Any) -> TyCon -> Either String (TyClDecl GhcRn)
forall (br :: BranchFlag).
PrintRuntimeReps
-> Maybe (CoAxiom br) -> TyCon -> Either String (TyClDecl GhcRn)
synifyTyCon PrintRuntimeReps
prr Maybe (CoAxiom Any)
forall a. Maybe a
Nothing TyCon
at_tc
             FamilyDecl GhcRn
famDecl <- TyClDecl GhcRn -> Either String (FamilyDecl GhcRn)
forall a. TyClDecl a -> Either String (FamilyDecl a)
extractFamilyDecl TyClDecl GhcRn
tyDecl
             let defEqnTy :: Maybe (LTyFamDefltDecl GhcRn)
defEqnTy = ((Type, SrcSpan) -> LTyFamDefltDecl GhcRn)
-> Maybe (Type, SrcSpan) -> Maybe (LTyFamDefltDecl GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyFamDefltDecl GhcRn -> LTyFamDefltDecl GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (TyFamDefltDecl GhcRn -> LTyFamDefltDecl GhcRn)
-> ((Type, SrcSpan) -> TyFamDefltDecl GhcRn)
-> (Type, SrcSpan)
-> LTyFamDefltDecl GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn
extractFamDefDecl FamilyDecl GhcRn
famDecl (Type -> TyFamDefltDecl GhcRn)
-> ((Type, SrcSpan) -> Type)
-> (Type, SrcSpan)
-> TyFamDefltDecl GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type, SrcSpan) -> Type
forall a b. (a, b) -> a
fst) Maybe (Type, SrcSpan)
def
             (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))
-> Either String (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpanLess (LFamilyDecl GhcRn) -> LFamilyDecl GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc FamilyDecl GhcRn
SrcSpanLess (LFamilyDecl GhcRn)
famDecl, Maybe (LTyFamDefltDecl GhcRn)
defEqnTy)

           atTyClDecls :: [Either String (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))]
atTyClDecls = (ClassATItem
 -> Either
      String (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn)))
-> [ClassATItem]
-> [Either
      String (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))]
forall a b. (a -> b) -> [a] -> [b]
map ClassATItem
-> Either String (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))
extractAtItem (Class -> [ClassATItem]
classATItems Class
cl)
           ([LFamilyDecl GhcRn]
atFamDecls, [Maybe (LTyFamDefltDecl GhcRn)]
atDefFamDecls) = [(LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))]
-> ([LFamilyDecl GhcRn], [Maybe (LTyFamDefltDecl GhcRn)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([Either String (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))]
-> [(LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))]
forall a b. [Either a b] -> [b]
rights [Either String (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))]
atTyClDecls)
           vs :: [Id]
vs = TyCon -> [Id]
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 (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))]
-> [String]
forall a b. [Either a b] -> [a]
lefts [Either String (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl 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 NoExtField
XTyClD GhcRn
noExtField (TyClDecl GhcRn -> Either String ([String], HsDecl GhcRn))
-> TyClDecl GhcRn -> Either String ([String], HsDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ ClassDecl :: forall pass.
XClassDecl pass
-> LHsContext pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> [LHsFunDep pass]
-> [LSig pass]
-> LHsBinds pass
-> [LFamilyDecl pass]
-> [LTyFamDefltDecl pass]
-> [LDocDecl]
-> TyClDecl pass
ClassDecl
         { tcdCtxt :: LHsContext GhcRn
tcdCtxt = [Type] -> LHsContext GhcRn
synifyCtx (Class -> [Type]
classSCTheta Class
cl)
         , tcdLName :: Located (IdP GhcRn)
tcdLName = Class -> Located Name
forall n. NamedThing n => n -> Located Name
synifyName Class
cl
         , tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars = [Id] -> LHsQTyVars GhcRn
synifyTyVars [Id]
vs
         , tcdFixity :: LexicalFixity
tcdFixity = Class -> LexicalFixity
forall n. NamedThing n => n -> LexicalFixity
synifyFixity Class
cl
         , tcdFDs :: [LHsFunDep GhcRn]
tcdFDs = (([Id], [Id]) -> Located (FunDep (Located Name)))
-> [([Id], [Id])] -> [Located (FunDep (Located Name))]
forall a b. (a -> b) -> [a] -> [b]
map (\ ([Id]
l,[Id]
r) -> SrcSpanLess (Located (FunDep (Located Name)))
-> Located (FunDep (Located Name))
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc
                        ((Id -> Located Name) -> [Id] -> [Located Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (Name -> Located Name) -> (Id -> Name) -> Id -> Located Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
forall a. NamedThing a => a -> Name
getName) [Id]
l, (Id -> Located Name) -> [Id] -> [Located Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (Name -> Located Name) -> (Id -> Name) -> Id -> Located Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
forall a. NamedThing a => a -> Name
getName) [Id]
r) ) ([([Id], [Id])] -> [Located (FunDep (Located Name))])
-> [([Id], [Id])] -> [Located (FunDep (Located Name))]
forall a b. (a -> b) -> a -> b
$
                         ([Id], [([Id], [Id])]) -> [([Id], [Id])]
forall a b. (a, b) -> b
snd (([Id], [([Id], [Id])]) -> [([Id], [Id])])
-> ([Id], [([Id], [Id])]) -> [([Id], [Id])]
forall a b. (a -> b) -> a -> b
$ Class -> ([Id], [([Id], [Id])])
classTvsFds Class
cl
         , tcdSigs :: [LSig GhcRn]
tcdSigs = SrcSpanLess (LSig GhcRn) -> LSig GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XMinimalSig GhcRn
-> SourceText -> LBooleanFormula (Located (IdP GhcRn)) -> Sig GhcRn
forall pass.
XMinimalSig pass
-> SourceText -> LBooleanFormula (Located (IdP pass)) -> Sig pass
MinimalSig NoExtField
XMinimalSig GhcRn
noExtField SourceText
NoSourceText (GenLocated SrcSpan (BooleanFormula (Located Name)) -> Sig GhcRn)
-> (BooleanFormula Name
    -> GenLocated SrcSpan (BooleanFormula (Located Name)))
-> BooleanFormula Name
-> Sig GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BooleanFormula (Located Name)
-> GenLocated SrcSpan (BooleanFormula (Located Name))
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (BooleanFormula (Located Name)
 -> GenLocated SrcSpan (BooleanFormula (Located Name)))
-> (BooleanFormula Name -> BooleanFormula (Located Name))
-> BooleanFormula Name
-> GenLocated SrcSpan (BooleanFormula (Located Name))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Located Name)
-> BooleanFormula Name -> BooleanFormula (Located Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (BooleanFormula Name -> Sig GhcRn)
-> BooleanFormula Name -> Sig GhcRn
forall a b. (a -> b) -> a -> b
$ Class -> BooleanFormula Name
classMinimalDef Class
cl) LSig GhcRn -> [LSig GhcRn] -> [LSig GhcRn]
forall a. a -> [a] -> [a]
:
                      [ SrcSpanLess (LSig GhcRn) -> LSig GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc Sig GhcRn
SrcSpanLess (LSig GhcRn)
tcdSig
                      | ClassOpItem
clsOp <- Class -> [ClassOpItem]
classOpItems Class
cl
                      , Sig GhcRn
tcdSig <- [Id] -> ClassOpItem -> [Sig GhcRn]
synifyTcIdSig [Id]
vs ClassOpItem
clsOp ]
         , tcdMeths :: LHsBinds GhcRn
tcdMeths = LHsBinds 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]
atFamDecls
         , tcdATDefs :: [LTyFamDefltDecl GhcRn]
tcdATDefs = [Maybe (LTyFamDefltDecl GhcRn)] -> [LTyFamDefltDecl GhcRn]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (LTyFamDefltDecl GhcRn)]
atDefFamDecls
         , tcdDocs :: [LDocDecl]
tcdDocs = [] --we don't have any docs at this point
         , tcdCExt :: XClassDecl GhcRn
tcdCExt = XClassDecl GhcRn
NameSet
placeHolderNamesTc }
    | Bool
otherwise
    -> PrintRuntimeReps
-> Maybe (CoAxiom Any) -> TyCon -> Either String (TyClDecl GhcRn)
forall (br :: BranchFlag).
PrintRuntimeReps
-> Maybe (CoAxiom br) -> TyCon -> Either String (TyClDecl GhcRn)
synifyTyCon PrintRuntimeReps
prr Maybe (CoAxiom Any)
forall a. Maybe a
Nothing TyCon
tc Either String (TyClDecl GhcRn)
-> (TyClDecl GhcRn -> Either String ([String], HsDecl GhcRn))
-> Either String ([String], HsDecl GhcRn)
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 NoExtField
XTyClD GhcRn
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 (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 NoExtField
XSigD GhcRn
noExtField (XTypeSig GhcRn
-> [Located (IdP GhcRn)] -> LHsSigWcType GhcRn -> Sig GhcRn
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
TypeSig NoExtField
XTypeSig GhcRn
noExtField [DataCon -> Located Name
forall n. NamedThing n => n -> Located Name
synifyName DataCon
dc]
    (SynifyTypeState -> [Id] -> Type -> LHsSigWcType GhcRn
synifySigWcType SynifyTypeState
ImplicitizeForAll [] (DataCon -> Type
dataConUserType 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 NoExtField
XSigD GhcRn
noExtField (Sig GhcRn -> Either String ([String], HsDecl GhcRn))
-> Sig GhcRn -> Either String ([String], HsDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ XPatSynSig GhcRn
-> [Located (IdP GhcRn)] -> LHsSigType GhcRn -> Sig GhcRn
forall pass.
XPatSynSig pass
-> [Located (IdP pass)] -> LHsSigType pass -> Sig pass
PatSynSig NoExtField
XPatSynSig GhcRn
noExtField [PatSyn -> Located Name
forall n. NamedThing n => n -> Located Name
synifyName 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 (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 (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 -> TyFamInstEqn GhcRn
synifyAxBranch TyCon
tc (CoAxBranch { cab_tvs :: CoAxBranch -> [Id]
cab_tvs = [Id]
tkvs, cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
args, cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs })
  = let name :: Located Name
name            = TyCon -> Located Name
forall n. NamedThing n => n -> Located Name
synifyName TyCon
tc
        args_types_only :: [Type]
args_types_only = TyCon -> [Type] -> [Type]
filterOutInvisibleTypes TyCon
tc [Type]
args
        typats :: [LHsType GhcRn]
typats          = (Type -> LHsType GhcRn) -> [Type] -> [LHsType GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType []) [Type]
args_types_only
        annot_typats :: [LHsType GhcRn]
annot_typats    = (Bool -> Type -> LHsType GhcRn -> LHsType GhcRn)
-> [Bool] -> [Type] -> [LHsType GhcRn] -> [LHsType GhcRn]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Bool -> Type -> LHsType GhcRn -> LHsType GhcRn
annotHsType [Bool]
args_poly [Type]
args_types_only [LHsType GhcRn]
typats
        hs_rhs :: LHsType GhcRn
hs_rhs          = SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [] Type
rhs
    in HsIB :: forall pass thing.
XHsIB pass thing -> thing -> HsImplicitBndrs pass thing
HsIB { hsib_ext :: XHsIB GhcRn (FamEqn GhcRn (LHsType GhcRn))
hsib_ext = (Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
tyVarName [Id]
tkvs
            , hsib_body :: FamEqn GhcRn (LHsType GhcRn)
hsib_body   = FamEqn :: forall pass rhs.
XCFamEqn pass rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr pass]
-> HsTyPats pass
-> LexicalFixity
-> rhs
-> FamEqn pass rhs
FamEqn { feqn_ext :: XCFamEqn GhcRn (LHsType GhcRn)
feqn_ext    = NoExtField
XCFamEqn GhcRn (LHsType GhcRn)
noExtField
                                   , feqn_tycon :: Located (IdP GhcRn)
feqn_tycon  = Located (IdP GhcRn)
Located Name
name
                                   , feqn_bndrs :: Maybe [LHsTyVarBndr GhcRn]
feqn_bndrs  = Maybe [LHsTyVarBndr GhcRn]
forall a. Maybe a
Nothing
                                       -- TODO: this must change eventually
                                   , feqn_pats :: HsTyPats GhcRn
feqn_pats   = (LHsType GhcRn -> HsArg (LHsType GhcRn) (LHsType GhcRn))
-> [LHsType GhcRn] -> HsTyPats GhcRn
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcRn -> HsArg (LHsType GhcRn) (LHsType GhcRn)
forall tm ty. tm -> HsArg tm ty
HsValArg [LHsType GhcRn]
annot_typats
                                   , feqn_fixity :: LexicalFixity
feqn_fixity = Located Name -> LexicalFixity
forall n. NamedThing n => n -> LexicalFixity
synifyFixity Located Name
name
                                   , feqn_rhs :: LHsType GhcRn
feqn_rhs    = LHsType GhcRn
hs_rhs } }
  where
    args_poly :: [Bool]
args_poly = TyCon -> [Bool]
tyConArgsPolyKinded TyCon
tc

synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn)
synifyAxiom :: 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 (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 NoExtField
XInstD GhcRn
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 NoExtField
XTyFamInstD GhcRn
noExtField
           (TyFamDefltDecl GhcRn -> InstDecl GhcRn)
-> TyFamDefltDecl GhcRn -> InstDecl GhcRn
forall a b. (a -> b) -> a -> b
$ TyFamInstDecl :: forall pass. TyFamInstEqn pass -> TyFamInstDecl pass
TyFamInstDecl { tfid_eqn :: TyFamInstEqn GhcRn
tfid_eqn = TyCon -> CoAxBranch -> TyFamInstEqn 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HsDecl GhcRn -> Either String (HsDecl GhcRn)
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 NoExtField
XTyClD GhcRn
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 ErrMsg (TyClDecl GhcRn)
synifyTyCon :: PrintRuntimeReps
-> Maybe (CoAxiom br) -> TyCon -> Either String (TyClDecl GhcRn)
synifyTyCon PrintRuntimeReps
prr Maybe (CoAxiom br)
_coax TyCon
tc
  | TyCon -> Bool
isFunTyCon TyCon
tc Bool -> Bool -> Bool
|| TyCon -> Bool
isPrimTyCon TyCon
tc
  = TyClDecl GhcRn -> Either String (TyClDecl GhcRn)
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 :: forall pass.
XDataDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> HsDataDefn pass
-> TyClDecl pass
DataDecl { tcdLName :: Located (IdP GhcRn)
tcdLName = TyCon -> Located Name
forall n. NamedThing n => n -> Located Name
synifyName TyCon
tc
             , tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars = HsQTvs :: forall pass. XHsQTvs pass -> [LHsTyVarBndr pass] -> LHsQTyVars pass
HsQTvs  { hsq_ext :: XHsQTvs GhcRn
hsq_ext = []   -- No kind polymorphism
                                   , hsq_explicit :: [LHsTyVarBndr GhcRn]
hsq_explicit = (Type -> Id -> LHsTyVarBndr GhcRn)
-> [Type] -> [Id] -> [LHsTyVarBndr GhcRn]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Id -> LHsTyVarBndr GhcRn
forall p a.
(HasSrcSpan p, NamedThing a, SrcSpanLess p ~ HsTyVarBndr GhcRn) =>
Type -> a -> p
mk_hs_tv
                                                            [Type]
tyVarKinds
                                                            [Id]
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 :: forall pass.
XCHsDataDefn pass
-> NewOrData
-> LHsContext pass
-> Maybe (Located CType)
-> Maybe (LHsKind pass)
-> [LConDecl pass]
-> HsDeriving pass
-> HsDataDefn pass
HsDataDefn { dd_ext :: XCHsDataDefn GhcRn
dd_ext = NoExtField
XCHsDataDefn GhcRn
noExtField
                                      , dd_ND :: NewOrData
dd_ND = NewOrData
DataType  -- arbitrary lie, they are neither
                                                    -- algebraic data nor newtype:
                                      , dd_ctxt :: LHsContext GhcRn
dd_ctxt = SrcSpanLess (LHsContext GhcRn) -> LHsContext GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc []
                                      , dd_cType :: Maybe (Located CType)
dd_cType = Maybe (Located CType)
forall a. Maybe a
Nothing
                                      , dd_kindSig :: Maybe (LHsType GhcRn)
dd_kindSig = TyCon -> Maybe (LHsType GhcRn)
synifyDataTyConReturnKind TyCon
tc
                                               -- we have their kind accurately:
                                      , dd_cons :: [LConDecl GhcRn]
dd_cons = []  -- No constructors
                                      , dd_derivs :: HsDeriving GhcRn
dd_derivs = SrcSpanLess (HsDeriving GhcRn) -> HsDeriving GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [] }
           , tcdDExt :: XDataDecl GhcRn
tcdDExt = Bool -> NameSet -> DataDeclRn
DataDeclRn Bool
False NameSet
placeHolderNamesTc }
  where
    -- tyConTyVars doesn't work on fun/prim, but we can make them up:
    mk_hs_tv :: Type -> a -> p
mk_hs_tv Type
realKind a
fakeTyVar
      | Type -> Bool
isLiftedTypeKind Type
realKind = SrcSpanLess p -> p
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess p -> p) -> SrcSpanLess p -> p
forall a b. (a -> b) -> a -> b
$ XUserTyVar GhcRn -> Located (IdP GhcRn) -> HsTyVarBndr GhcRn
forall pass.
XUserTyVar pass -> Located (IdP pass) -> HsTyVarBndr pass
UserTyVar NoExtField
XUserTyVar GhcRn
noExtField (SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (a -> Name
forall a. NamedThing a => a -> Name
getName a
fakeTyVar))
      | Bool
otherwise = SrcSpanLess p -> p
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess p -> p) -> SrcSpanLess p -> p
forall a b. (a -> b) -> a -> b
$ XKindedTyVar GhcRn
-> Located (IdP GhcRn) -> LHsType GhcRn -> HsTyVarBndr GhcRn
forall pass.
XKindedTyVar pass
-> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr pass
KindedTyVar NoExtField
XKindedTyVar GhcRn
noExtField (SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (a -> Name
forall a. NamedThing a => a -> Name
getName a
fakeTyVar)) (Type -> LHsType GhcRn
synifyKindSig Type
realKind)

    conKind :: Type
conKind = PrintRuntimeReps -> Type -> Type
defaultType PrintRuntimeReps
prr (TyCon -> Type
tyConKind TyCon
tc)
    tyVarKinds :: [Type]
tyVarKinds = ([Type], Type) -> [Type]
forall a b. (a, b) -> a
fst (([Type], Type) -> [Type])
-> (Type -> ([Type], Type)) -> Type -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([Type], Type)
splitFunTys (Type -> ([Type], Type))
-> (Type -> Type) -> Type -> ([Type], Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TyCoBinder], Type) -> Type
forall a b. (a, b) -> b
snd (([TyCoBinder], Type) -> Type)
-> (Type -> ([TyCoBinder], Type)) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([TyCoBinder], Type)
splitPiTysInvisible (Type -> [Type]) -> Type -> [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 -> LTyFamInstEqn GhcRn)
-> [CoAxBranch] -> [LTyFamInstEqn GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (TyFamInstEqn GhcRn -> LTyFamInstEqn GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (TyFamInstEqn GhcRn -> LTyFamInstEqn GhcRn)
-> (CoAxBranch -> TyFamInstEqn GhcRn)
-> CoAxBranch
-> LTyFamInstEqn GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> CoAxBranch -> TyFamInstEqn 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
$ [LTyFamInstEqn GhcRn] -> Maybe [LTyFamInstEqn 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
$ [LTyFamInstEqn GhcRn] -> Maybe [LTyFamInstEqn 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]
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
famTcResVar TyCon
tc
    mkFamDecl :: FamilyInfo GhcRn -> Either String (TyClDecl GhcRn)
mkFamDecl FamilyInfo GhcRn
i = TyClDecl GhcRn -> Either String (TyClDecl GhcRn)
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 NoExtField
XFamDecl GhcRn
noExtField (FamilyDecl GhcRn -> TyClDecl GhcRn)
-> FamilyDecl GhcRn -> TyClDecl GhcRn
forall a b. (a -> b) -> a -> b
$
      FamilyDecl :: forall pass.
XCFamilyDecl pass
-> FamilyInfo pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> LFamilyResultSig pass
-> Maybe (LInjectivityAnn pass)
-> FamilyDecl pass
FamilyDecl { fdExt :: XCFamilyDecl GhcRn
fdExt = NoExtField
XCFamilyDecl GhcRn
noExtField
                 , fdInfo :: FamilyInfo GhcRn
fdInfo = FamilyInfo GhcRn
i
                 , fdLName :: Located (IdP GhcRn)
fdLName = TyCon -> Located Name
forall n. NamedThing n => n -> Located Name
synifyName TyCon
tc
                 , fdTyVars :: LHsQTyVars GhcRn
fdTyVars = [Id] -> LHsQTyVars GhcRn
synifyTyVars (TyCon -> [Id]
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 -> [Id] -> Injectivity -> Maybe (LInjectivityAnn GhcRn)
synifyInjectivityAnn  Maybe Name
resultVar (TyCon -> [Id]
tyConTyVars TyCon
tc)
                                       (TyCon -> Injectivity
tyConInjectivityInfo TyCon
tc)
                 }

synifyTyCon PrintRuntimeReps
_prr Maybe (CoAxiom br)
coax TyCon
tc
  | Just Type
ty <- TyCon -> Maybe Type
synTyConRhs_maybe TyCon
tc
  = TyClDecl GhcRn -> Either String (TyClDecl GhcRn)
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 :: forall pass.
XSynDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> LHsType pass
-> TyClDecl pass
SynDecl { tcdSExt :: XSynDecl GhcRn
tcdSExt   = XSynDecl GhcRn
NameSet
emptyNameSet
                     , tcdLName :: Located (IdP GhcRn)
tcdLName  = TyCon -> Located Name
forall n. NamedThing n => n -> Located Name
synifyName TyCon
tc
                     , tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars = [Id] -> LHsQTyVars GhcRn
synifyTyVars (TyCon -> [Id]
tyConVisibleTyVars TyCon
tc)
                     , tcdFixity :: LexicalFixity
tcdFixity = TyCon -> LexicalFixity
forall n. NamedThing n => n -> LexicalFixity
synifyFixity TyCon
tc
                     , tcdRhs :: LHsType GhcRn
tcdRhs = SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [] Type
ty }
  | Bool
otherwise =
  -- (closed) newtype and data
  let
  alg_nd :: NewOrData
alg_nd = if TyCon -> Bool
isNewTyCon TyCon
tc then NewOrData
NewType else NewOrData
DataType
  alg_ctx :: LHsContext GhcRn
alg_ctx = [Type] -> LHsContext GhcRn
synifyCtx (TyCon -> [Type]
tyConStupidTheta TyCon
tc)
  name :: Located Name
name = case Maybe (CoAxiom br)
coax of
    Just CoAxiom br
a -> CoAxiom br -> Located Name
forall n. NamedThing n => n -> Located Name
synifyName CoAxiom br
a -- Data families are named according to their
                           -- CoAxioms, not their TyCons
    Maybe (CoAxiom br)
_ -> TyCon -> Located Name
forall n. NamedThing n => n -> Located Name
synifyName TyCon
tc
  tyvars :: LHsQTyVars GhcRn
tyvars = [Id] -> LHsQTyVars GhcRn
synifyTyVars (TyCon -> [Id]
tyConVisibleTyVars TyCon
tc)
  kindSig :: Maybe (LHsType GhcRn)
kindSig = TyCon -> Maybe (LHsType 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 :: [Either String (LConDecl GhcRn)]
consRaw = (DataCon -> Either String (LConDecl GhcRn))
-> [DataCon] -> [Either String (LConDecl GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> DataCon -> Either String (LConDecl GhcRn)
synifyDataCon Bool
use_gadt_syntax) (TyCon -> [DataCon]
tyConDataCons TyCon
tc)
  cons :: [LConDecl GhcRn]
cons = [Either String (LConDecl GhcRn)] -> [LConDecl GhcRn]
forall a b. [Either a b] -> [b]
rights [Either String (LConDecl GhcRn)]
consRaw
  -- "deriving" doesn't affect the signature, no need to specify any.
  alg_deriv :: HsDeriving GhcRn
alg_deriv = SrcSpanLess (HsDeriving GhcRn) -> HsDeriving GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc []
  defn :: HsDataDefn GhcRn
defn = HsDataDefn :: forall pass.
XCHsDataDefn pass
-> NewOrData
-> LHsContext pass
-> Maybe (Located CType)
-> Maybe (LHsKind pass)
-> [LConDecl pass]
-> HsDeriving pass
-> HsDataDefn pass
HsDataDefn { dd_ext :: XCHsDataDefn GhcRn
dd_ext     = NoExtField
XCHsDataDefn GhcRn
noExtField
                    , dd_ND :: NewOrData
dd_ND      = NewOrData
alg_nd
                    , dd_ctxt :: LHsContext GhcRn
dd_ctxt    = LHsContext GhcRn
alg_ctx
                    , dd_cType :: Maybe (Located CType)
dd_cType   = Maybe (Located CType)
forall a. Maybe a
Nothing
                    , dd_kindSig :: Maybe (LHsType GhcRn)
dd_kindSig = Maybe (LHsType GhcRn)
kindSig
                    , dd_cons :: [LConDecl GhcRn]
dd_cons    = [LConDecl GhcRn]
cons
                    , dd_derivs :: HsDeriving GhcRn
dd_derivs  = HsDeriving GhcRn
alg_deriv }
 in case [Either String (LConDecl GhcRn)] -> [String]
forall a b. [Either a b] -> [a]
lefts [Either String (LConDecl GhcRn)]
consRaw of
  [] -> TyClDecl GhcRn -> Either String (TyClDecl GhcRn)
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 :: forall pass.
XDataDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> HsDataDefn pass
-> TyClDecl pass
DataDecl { tcdLName :: Located (IdP GhcRn)
tcdLName = Located (IdP GhcRn)
Located Name
name, tcdTyVars :: LHsQTyVars GhcRn
tcdTyVars = LHsQTyVars GhcRn
tyvars
                 , tcdFixity :: LexicalFixity
tcdFixity = Located Name -> LexicalFixity
forall n. NamedThing n => n -> LexicalFixity
synifyFixity Located Name
name
                 , tcdDataDefn :: HsDataDefn GhcRn
tcdDataDefn = HsDataDefn GhcRn
defn
                 , tcdDExt :: XDataDecl GhcRn
tcdDExt = Bool -> NameSet -> DataDeclRn
DataDeclRn Bool
False NameSet
placeHolderNamesTc }
  [String]
dataConErrs -> String -> Either String (TyClDecl GhcRn)
forall a b. a -> Either a b
Left (String -> Either String (TyClDecl GhcRn))
-> String -> Either String (TyClDecl GhcRn)
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
dataConErrs

-- | 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 (LHsType GhcRn)
synifyDataTyConReturnKind TyCon
tc
  | Type -> Bool
isLiftedTypeKind Type
ret_kind = Maybe (LHsType GhcRn)
forall a. Maybe a
Nothing -- Don't bother displaying :: *
  | Bool
otherwise                 = LHsType GhcRn -> Maybe (LHsType GhcRn)
forall a. a -> Maybe a
Just (Type -> LHsType 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 -> [Id] -> Injectivity -> Maybe (LInjectivityAnn GhcRn)
synifyInjectivityAnn Maybe Name
Nothing [Id]
_ Injectivity
_            = Maybe (LInjectivityAnn GhcRn)
forall a. Maybe a
Nothing
synifyInjectivityAnn Maybe Name
_       [Id]
_ Injectivity
NotInjective = Maybe (LInjectivityAnn GhcRn)
forall a. Maybe a
Nothing
synifyInjectivityAnn (Just Name
lhs) [Id]
tvs (Injective [Bool]
inj) =
    let rhs :: [Located Name]
rhs = (Id -> Located Name) -> [Id] -> [Located Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (Name -> Located Name) -> (Id -> Name) -> Id -> Located Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
tyVarName) ([Bool] -> [Id] -> [Id]
forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
inj [Id]
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
$ SrcSpanLess (LInjectivityAnn GhcRn) -> LInjectivityAnn GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LInjectivityAnn GhcRn) -> LInjectivityAnn GhcRn)
-> SrcSpanLess (LInjectivityAnn GhcRn) -> LInjectivityAnn GhcRn
forall a b. (a -> b) -> a -> b
$ Located (IdP GhcRn)
-> [Located (IdP GhcRn)] -> InjectivityAnn GhcRn
forall pass.
Located (IdP pass) -> [Located (IdP pass)] -> InjectivityAnn pass
InjectivityAnn (SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located Name)
Name
lhs) [Located (IdP GhcRn)]
[Located Name]
rhs

synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn
synifyFamilyResultSig :: Maybe Name -> Type -> LFamilyResultSig GhcRn
synifyFamilyResultSig  Maybe Name
Nothing    Type
kind
   | Type -> Bool
isLiftedTypeKind Type
kind = SrcSpanLess (LFamilyResultSig GhcRn) -> LFamilyResultSig GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LFamilyResultSig GhcRn) -> LFamilyResultSig GhcRn)
-> SrcSpanLess (LFamilyResultSig GhcRn) -> LFamilyResultSig GhcRn
forall a b. (a -> b) -> a -> b
$ XNoSig GhcRn -> FamilyResultSig GhcRn
forall pass. XNoSig pass -> FamilyResultSig pass
NoSig NoExtField
XNoSig GhcRn
noExtField
   | Bool
otherwise = SrcSpanLess (LFamilyResultSig GhcRn) -> LFamilyResultSig GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LFamilyResultSig GhcRn) -> LFamilyResultSig GhcRn)
-> SrcSpanLess (LFamilyResultSig GhcRn) -> LFamilyResultSig GhcRn
forall a b. (a -> b) -> a -> b
$ XCKindSig GhcRn -> LHsType GhcRn -> FamilyResultSig GhcRn
forall pass. XCKindSig pass -> LHsKind pass -> FamilyResultSig pass
KindSig  NoExtField
XCKindSig GhcRn
noExtField (Type -> LHsType GhcRn
synifyKindSig Type
kind)
synifyFamilyResultSig (Just Name
name) Type
kind =
   SrcSpanLess (LFamilyResultSig GhcRn) -> LFamilyResultSig GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LFamilyResultSig GhcRn) -> LFamilyResultSig GhcRn)
-> SrcSpanLess (LFamilyResultSig GhcRn) -> LFamilyResultSig GhcRn
forall a b. (a -> b) -> a -> b
$ XTyVarSig GhcRn -> LHsTyVarBndr GhcRn -> FamilyResultSig GhcRn
forall pass.
XTyVarSig pass -> LHsTyVarBndr pass -> FamilyResultSig pass
TyVarSig NoExtField
XTyVarSig GhcRn
noExtField (SrcSpanLess (LHsTyVarBndr GhcRn) -> LHsTyVarBndr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsTyVarBndr GhcRn) -> LHsTyVarBndr GhcRn)
-> SrcSpanLess (LHsTyVarBndr GhcRn) -> LHsTyVarBndr GhcRn
forall a b. (a -> b) -> a -> b
$ XKindedTyVar GhcRn
-> Located (IdP GhcRn) -> LHsType GhcRn -> HsTyVarBndr GhcRn
forall pass.
XKindedTyVar pass
-> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr pass
KindedTyVar NoExtField
XKindedTyVar GhcRn
noExtField (SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located Name)
Name
name) (Type -> LHsType 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 ErrMsg (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 ([LConDeclField GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LConDeclField GhcRn]
field_tys)
  name :: Located Name
name = DataCon -> Located Name
forall n. NamedThing n => n -> Located Name
synifyName DataCon
dc
  -- con_qvars means a different thing depending on gadt-syntax
  ([Id]
_univ_tvs, [Id]
ex_tvs, [EqSpec]
_eq_spec, [Type]
theta, [Type]
arg_tys, Type
res_ty) = DataCon -> ([Id], [Id], [EqSpec], [Type], [Type], Type)
dataConFullSig DataCon
dc
  user_tvs :: [Id]
user_tvs = DataCon -> [Id]
dataConUserTyVars DataCon
dc -- Used for GADT data constructors

  -- skip any EqTheta, use 'orig'inal syntax
  ctx :: Maybe (LHsContext GhcRn)
ctx | [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
theta = Maybe (LHsContext 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 :: [LHsType GhcRn]
linear_tys =
    (Type -> HsSrcBang -> LHsType GhcRn)
-> [Type] -> [HsSrcBang] -> [LHsType GhcRn]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Type
ty HsSrcBang
bang ->
               let tySyn :: LHsType GhcRn
tySyn = SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [] Type
ty
               in case HsSrcBang
bang of
                    (HsSrcBang SourceText
_ SrcUnpackedness
NoSrcUnpack SrcStrictness
NoSrcStrict) -> LHsType GhcRn
tySyn
                    HsSrcBang
bang' -> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn)
-> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ XBangTy GhcRn -> HsSrcBang -> LHsType GhcRn -> HsType GhcRn
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy NoExtField
XBangTy GhcRn
noExtField HsSrcBang
bang' LHsType GhcRn
tySyn)
            [Type]
arg_tys (DataCon -> [HsSrcBang]
dataConSrcBangs DataCon
dc)

  field_tys :: [LConDeclField GhcRn]
field_tys = (FieldLabel -> LHsType GhcRn -> LConDeclField GhcRn)
-> [FieldLabel] -> [LHsType GhcRn] -> [LConDeclField GhcRn]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith FieldLabel -> LHsType GhcRn -> LConDeclField GhcRn
forall a pass.
(HasSrcSpan a, XConDeclField pass ~ NoExtField,
 SrcSpanLess a ~ ConDeclField pass) =>
FieldLbl (XCFieldOcc pass) -> LBangType pass -> a
con_decl_field (DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc) [LHsType GhcRn]
linear_tys
  con_decl_field :: FieldLbl (XCFieldOcc pass) -> LBangType pass -> a
con_decl_field FieldLbl (XCFieldOcc pass)
fl LBangType pass
synTy = SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess a -> a) -> SrcSpanLess a -> a
forall a b. (a -> b) -> a -> b
$
    XConDeclField pass
-> [LFieldOcc pass]
-> LBangType pass
-> Maybe LHsDocString
-> ConDeclField pass
forall pass.
XConDeclField pass
-> [LFieldOcc pass]
-> LBangType pass
-> Maybe LHsDocString
-> ConDeclField pass
ConDeclField NoExtField
XConDeclField pass
noExtField [SrcSpanLess (LFieldOcc pass) -> LFieldOcc pass
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LFieldOcc pass) -> LFieldOcc pass)
-> SrcSpanLess (LFieldOcc pass) -> LFieldOcc pass
forall a b. (a -> b) -> a -> b
$ XCFieldOcc pass -> Located RdrName -> FieldOcc pass
forall pass. XCFieldOcc pass -> Located RdrName -> FieldOcc pass
FieldOcc (FieldLbl (XCFieldOcc pass) -> XCFieldOcc pass
forall a. FieldLbl a -> a
flSelector FieldLbl (XCFieldOcc pass)
fl) (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located RdrName) -> Located RdrName)
-> SrcSpanLess (Located RdrName) -> Located RdrName
forall a b. (a -> b) -> a -> b
$ FastString -> RdrName
mkVarUnqual (FastString -> RdrName) -> FastString -> RdrName
forall a b. (a -> b) -> a -> b
$ FieldLbl (XCFieldOcc pass) -> FastString
forall a. FieldLbl a -> FastString
flLabel FieldLbl (XCFieldOcc pass)
fl)] LBangType pass
synTy
                 Maybe LHsDocString
forall a. Maybe a
Nothing
  hs_arg_tys :: Either
  String
  (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]))
hs_arg_tys = case (Bool
use_named_field_syntax, Bool
use_infix_syntax) of
          (Bool
True,Bool
True) -> String
-> Either
     String
     (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]))
forall a b. a -> Either a b
Left String
"synifyDataCon: contradiction!"
          (Bool
True,Bool
False) -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
-> Either
     String
     (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]))
forall (m :: * -> *) a. Monad m => a -> m a
return (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
 -> Either
      String
      (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])))
-> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
-> Either
     String
     (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]))
forall a b. (a -> b) -> a -> b
$ Located [LConDeclField GhcRn]
-> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
forall arg rec. rec -> HsConDetails arg rec
RecCon (SrcSpanLess (Located [LConDeclField GhcRn])
-> Located [LConDeclField GhcRn]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [LConDeclField GhcRn]
SrcSpanLess (Located [LConDeclField GhcRn])
field_tys)
          (Bool
False,Bool
False) -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
-> Either
     String
     (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]))
forall (m :: * -> *) a. Monad m => a -> m a
return (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
 -> Either
      String
      (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])))
-> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
-> Either
     String
     (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]))
forall a b. (a -> b) -> a -> b
$ [LHsType GhcRn]
-> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [LHsType GhcRn]
linear_tys
          (Bool
False,Bool
True) -> case [LHsType GhcRn]
linear_tys of
                           [LHsType GhcRn
a,LHsType GhcRn
b] -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
-> Either
     String
     (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]))
forall (m :: * -> *) a. Monad m => a -> m a
return (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
 -> Either
      String
      (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])))
-> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
-> Either
     String
     (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]))
forall a b. (a -> b) -> a -> b
$ LHsType GhcRn
-> LHsType GhcRn
-> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon LHsType GhcRn
a LHsType GhcRn
b
                           [LHsType GhcRn]
_ -> String
-> Either
     String
     (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]))
forall a b. a -> Either a b
Left String
"synifyDataCon: infix with non-2 args?"
 -- finally we get synifyDataCon's result!
 in Either
  String
  (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]))
hs_arg_tys Either
  String
  (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]))
-> (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
    -> Either String (LConDecl GhcRn))
-> Either String (LConDecl GhcRn)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      \HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
hat ->
        if Bool
use_gadt_syntax
           then LConDecl GhcRn -> Either String (LConDecl GhcRn)
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
$ SrcSpanLess (LConDecl GhcRn) -> LConDecl GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LConDecl GhcRn) -> LConDecl GhcRn)
-> SrcSpanLess (LConDecl GhcRn) -> LConDecl GhcRn
forall a b. (a -> b) -> a -> b
$
              ConDeclGADT :: forall pass.
XConDeclGADT pass
-> [Located (IdP pass)]
-> Located Bool
-> LHsQTyVars pass
-> Maybe (LHsContext pass)
-> HsConDeclDetails pass
-> LHsType pass
-> Maybe LHsDocString
-> ConDecl pass
ConDeclGADT { con_g_ext :: XConDeclGADT GhcRn
con_g_ext  = NoExtField
XConDeclGADT GhcRn
noExtField
                          , con_names :: [Located (IdP GhcRn)]
con_names  = [Located (IdP GhcRn)
Located Name
name]
                          , con_forall :: Located Bool
con_forall = SrcSpanLess (Located Bool) -> Located Bool
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located Bool) -> Located Bool)
-> SrcSpanLess (Located Bool) -> Located Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
user_tvs
                          , con_qvars :: LHsQTyVars GhcRn
con_qvars  = [Id] -> LHsQTyVars GhcRn
synifyTyVars [Id]
user_tvs
                          , con_mb_cxt :: Maybe (LHsContext GhcRn)
con_mb_cxt = Maybe (LHsContext GhcRn)
ctx
                          , con_args :: HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
con_args   = HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
hat
                          , con_res_ty :: LHsType GhcRn
con_res_ty = SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [] Type
res_ty
                          , con_doc :: Maybe LHsDocString
con_doc    = Maybe LHsDocString
forall a. Maybe a
Nothing }
           else LConDecl GhcRn -> Either String (LConDecl GhcRn)
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
$ SrcSpanLess (LConDecl GhcRn) -> LConDecl GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LConDecl GhcRn) -> LConDecl GhcRn)
-> SrcSpanLess (LConDecl GhcRn) -> LConDecl GhcRn
forall a b. (a -> b) -> a -> b
$
              ConDeclH98 :: forall pass.
XConDeclH98 pass
-> Located (IdP pass)
-> Located Bool
-> [LHsTyVarBndr pass]
-> Maybe (LHsContext pass)
-> HsConDeclDetails pass
-> Maybe LHsDocString
-> ConDecl pass
ConDeclH98 { con_ext :: XConDeclH98 GhcRn
con_ext    = NoExtField
XConDeclH98 GhcRn
noExtField
                         , con_name :: Located (IdP GhcRn)
con_name   = Located (IdP GhcRn)
Located Name
name
                         , con_forall :: Located Bool
con_forall = SrcSpanLess (Located Bool) -> Located Bool
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc Bool
SrcSpanLess (Located Bool)
False
                         , con_ex_tvs :: [LHsTyVarBndr GhcRn]
con_ex_tvs = (Id -> LHsTyVarBndr GhcRn) -> [Id] -> [LHsTyVarBndr GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map Id -> LHsTyVarBndr GhcRn
synifyTyVar [Id]
ex_tvs
                         , con_mb_cxt :: Maybe (LHsContext GhcRn)
con_mb_cxt = Maybe (LHsContext GhcRn)
ctx
                         , con_args :: HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
con_args   = HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
hat
                         , con_doc :: Maybe LHsDocString
con_doc    = Maybe LHsDocString
forall a. Maybe a
Nothing }

synifyName :: NamedThing n => n -> Located Name
synifyName :: n -> Located Name
synifyName n
n = SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L (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)

-- | 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 :: 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 -> [Id] -> Id -> Sig GhcRn
synifyIdSig PrintRuntimeReps
prr SynifyTypeState
s [Id]
vs Id
i = XTypeSig GhcRn
-> [Located (IdP GhcRn)] -> LHsSigWcType GhcRn -> Sig GhcRn
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
TypeSig NoExtField
XTypeSig GhcRn
noExtField [Id -> Located Name
forall n. NamedThing n => n -> Located Name
synifyName Id
i] (SynifyTypeState -> [Id] -> Type -> LHsSigWcType GhcRn
synifySigWcType SynifyTypeState
s [Id]
vs Type
t)
  where
    t :: Type
t = PrintRuntimeReps -> Type -> Type
defaultType PrintRuntimeReps
prr (Id -> Type
varType Id
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 :: [Id] -> ClassOpItem -> [Sig GhcRn]
synifyTcIdSig [Id]
vs (Id
i, DefMethInfo
dm) =
  [ XClassOpSig GhcRn
-> Bool -> [Located (IdP GhcRn)] -> LHsSigType GhcRn -> Sig GhcRn
forall pass.
XClassOpSig pass
-> Bool -> [Located (IdP pass)] -> LHsSigType pass -> Sig pass
ClassOpSig NoExtField
XClassOpSig GhcRn
noExtField Bool
False [Id -> Located Name
forall n. NamedThing n => n -> Located Name
synifyName Id
i] (Type -> LHsSigType GhcRn
mainSig (Id -> Type
varType Id
i)) ] [Sig GhcRn] -> [Sig GhcRn] -> [Sig GhcRn]
forall a. [a] -> [a] -> [a]
++
  [ XClassOpSig GhcRn
-> Bool -> [Located (IdP GhcRn)] -> LHsSigType GhcRn -> Sig GhcRn
forall pass.
XClassOpSig pass
-> Bool -> [Located (IdP pass)] -> LHsSigType pass -> Sig pass
ClassOpSig NoExtField
XClassOpSig GhcRn
noExtField Bool
True [SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located Name)
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 -> [Id] -> Type -> LHsSigType GhcRn
synifySigType SynifyTypeState
DeleteTopLevelQuantification [Id]
vs Type
t
    defSig :: Type -> LHsSigType GhcRn
defSig Type
t = SynifyTypeState -> [Id] -> Type -> LHsSigType GhcRn
synifySigType SynifyTypeState
ImplicitizeForAll [Id]
vs Type
t

synifyCtx :: [PredType] -> LHsContext GhcRn
synifyCtx :: [Type] -> LHsContext GhcRn
synifyCtx = [LHsType GhcRn] -> LHsContext GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc ([LHsType GhcRn] -> LHsContext GhcRn)
-> ([Type] -> [LHsType GhcRn]) -> [Type] -> LHsContext GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> LHsType GhcRn) -> [Type] -> [LHsType GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [])


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

synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn
synifyTyVar :: Id -> LHsTyVarBndr GhcRn
synifyTyVar = VarSet -> Id -> LHsTyVarBndr GhcRn
synifyTyVar' VarSet
emptyVarSet

-- | Like 'synifyTyVar', but accepts a set of variables for which to omit kind
-- signatures (even if they don't have the lifted type kind).
synifyTyVar' :: VarSet -> TyVar -> LHsTyVarBndr GhcRn
synifyTyVar' :: VarSet -> Id -> LHsTyVarBndr GhcRn
synifyTyVar' VarSet
no_kinds Id
tv
  | Type -> Bool
isLiftedTypeKind Type
kind Bool -> Bool -> Bool
|| Id
tv Id -> VarSet -> Bool
`elemVarSet` VarSet
no_kinds
  = SrcSpanLess (LHsTyVarBndr GhcRn) -> LHsTyVarBndr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XUserTyVar GhcRn -> Located (IdP GhcRn) -> HsTyVarBndr GhcRn
forall pass.
XUserTyVar pass -> Located (IdP pass) -> HsTyVarBndr pass
UserTyVar NoExtField
XUserTyVar GhcRn
noExtField (SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located Name)
Name
name))
  | Bool
otherwise = SrcSpanLess (LHsTyVarBndr GhcRn) -> LHsTyVarBndr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XKindedTyVar GhcRn
-> Located (IdP GhcRn) -> LHsType GhcRn -> HsTyVarBndr GhcRn
forall pass.
XKindedTyVar pass
-> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr pass
KindedTyVar NoExtField
XKindedTyVar GhcRn
noExtField (SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located Name)
Name
name) (Type -> LHsType GhcRn
synifyKindSig Type
kind))
  where
    kind :: Type
kind = Id -> Type
tyVarKind Id
tv
    name :: Name
name = Id -> Name
forall a. NamedThing a => a -> Name
getName Id
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 -> LHsType GhcRn -> LHsType GhcRn
annotHsType Bool
_    Type
_  hs_ty :: LHsType GhcRn
hs_ty@(L SrcSpan
_ (HsKindSig {})) = LHsType GhcRn
hs_ty
annotHsType Bool
True Type
ty LHsType 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
$ (Id -> Bool) -> VarSet -> VarSet
filterVarSet Id -> 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 :: LHsType GhcRn
hs_ki = SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [] Type
ki
    in SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XKindSig GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XKindSig pass -> LHsType pass -> LHsType pass -> HsType pass
HsKindSig NoExtField
XKindSig GhcRn
noExtField LHsType GhcRn
hs_ty LHsType GhcRn
hs_ki)
annotHsType Bool
_    Type
_ LHsType GhcRn
hs_ty = LHsType 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 =
     (Id -> Bool) -> [Id] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Bool
is_poly_ty (Type -> Bool) -> (Id -> Type) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
tyVarKind)      [Id]
tc_vis_tvs
  [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ (TyCoBinder -> Bool) -> [TyCoBinder] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Bool
is_poly_ty (Type -> Bool) -> (TyCoBinder -> Type) -> TyCoBinder -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCoBinder -> Type
tyCoBinderType) [TyCoBinder]
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
$
                    (Id -> Bool) -> VarSet -> VarSet
filterVarSet Id -> 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 :: [Id]
tc_vis_tvs = TyCon -> [Id]
tyConVisibleTyVars TyCon
tc

    tc_res_kind_vis_bndrs :: [TyCoBinder]
    tc_res_kind_vis_bndrs :: [TyCoBinder]
tc_res_kind_vis_bndrs = (TyCoBinder -> Bool) -> [TyCoBinder] -> [TyCoBinder]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCoBinder -> Bool
isVisibleBinder ([TyCoBinder] -> [TyCoBinder]) -> [TyCoBinder] -> [TyCoBinder]
forall a b. (a -> b) -> a -> b
$ ([TyCoBinder], Type) -> [TyCoBinder]
forall a b. (a, b) -> a
fst (([TyCoBinder], Type) -> [TyCoBinder])
-> ([TyCoBinder], Type) -> [TyCoBinder]
forall a b. (a -> b) -> a -> b
$ Type -> ([TyCoBinder], Type)
splitPiTys (Type -> ([TyCoBinder], Type)) -> Type -> ([TyCoBinder], 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 empty binders is a bit suspicious;
-- what if the type has free variables?
synifySigType :: SynifyTypeState -> [Id] -> Type -> LHsSigType GhcRn
synifySigType SynifyTypeState
s [Id]
vs Type
ty = LHsType GhcRn -> LHsSigType GhcRn
forall thing. thing -> HsImplicitBndrs GhcRn thing
mkEmptyImplicitBndrs (SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
s [Id]
vs Type
ty)

synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn
-- Ditto (see synifySigType)
synifySigWcType :: SynifyTypeState -> [Id] -> Type -> LHsSigWcType GhcRn
synifySigWcType SynifyTypeState
s [Id]
vs Type
ty = LHsSigType GhcRn -> LHsSigWcType GhcRn
forall thing. thing -> HsWildCardBndrs GhcRn thing
mkEmptyWildCardBndrs (LHsType GhcRn -> LHsSigType GhcRn
forall thing. thing -> HsImplicitBndrs GhcRn thing
mkEmptyImplicitBndrs (SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
s [Id]
vs Type
ty))

synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn
-- Ditto (see synifySigType)
synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn
synifyPatSynSigType PatSyn
ps = LHsType GhcRn -> LHsSigType GhcRn
forall thing. thing -> HsImplicitBndrs GhcRn thing
mkEmptyImplicitBndrs (PatSyn -> LHsType 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 -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
_ [Id]
_ (TyVarTy Id
tv) = SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn)
-> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ XTyVar GhcRn
-> PromotionFlag -> Located (IdP GhcRn) -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar NoExtField
XTyVar GhcRn
noExtField PromotionFlag
NotPromoted (Located (IdP GhcRn) -> HsType GhcRn)
-> Located (IdP GhcRn) -> HsType GhcRn
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
tv)
synifyType SynifyTypeState
_ [Id]
vs (TyConApp TyCon
tc [Type]
tys)
  = LHsType GhcRn -> LHsType GhcRn
maybe_sig LHsType GhcRn
res_ty
  where
    res_ty :: LHsType GhcRn
    res_ty :: LHsType 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
lev []] <- [Type]
tys
      , TyCon
lev TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
liftedRepDataConKey
      = SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XTyVar GhcRn
-> PromotionFlag -> Located (IdP GhcRn) -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar NoExtField
XTyVar GhcRn
noExtField PromotionFlag
NotPromoted (SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located Name)
Name
liftedTypeKindTyConName))
      -- Use non-prefix tuple syntax where possible, because it looks nicer.
      | Just TupleSort
sort <- TyCon -> Maybe TupleSort
tyConTuple_maybe TyCon
tc
      , TyCon -> Int
tyConArity TyCon
tc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tys_len
      = SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn)
-> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ XTupleTy GhcRn -> HsTupleSort -> [LHsType GhcRn] -> HsType GhcRn
forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy NoExtField
XTupleTy GhcRn
noExtField
                          (case TupleSort
sort of
                              TupleSort
BoxedTuple      -> HsTupleSort
HsBoxedTuple
                              TupleSort
ConstraintTuple -> HsTupleSort
HsConstraintTuple
                              TupleSort
UnboxedTuple    -> HsTupleSort
HsUnboxedTuple)
                           ((Type -> LHsType GhcRn) -> [Type] -> [LHsType GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [Id]
vs) [Type]
vis_tys)
      | TyCon -> Bool
isUnboxedSumTyCon TyCon
tc = SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn)
-> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ XSumTy GhcRn -> [LHsType GhcRn] -> HsType GhcRn
forall pass. XSumTy pass -> [LHsType pass] -> HsType pass
HsSumTy NoExtField
XSumTy GhcRn
noExtField ((Type -> LHsType GhcRn) -> [Type] -> [LHsType GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [Id]
vs) [Type]
vis_tys)
      | Just DataCon
dc <- TyCon -> Maybe DataCon
isPromotedDataCon_maybe TyCon
tc
      , DataCon -> Bool
isTupleDataCon DataCon
dc
      , DataCon -> Int
dataConSourceArity DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
vis_tys
      = SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn)
-> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ XExplicitTupleTy GhcRn -> [LHsType GhcRn] -> HsType GhcRn
forall pass. XExplicitTupleTy pass -> [LHsType pass] -> HsType pass
HsExplicitTupleTy NoExtField
XExplicitTupleTy GhcRn
noExtField ((Type -> LHsType GhcRn) -> [Type] -> [LHsType GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [Id]
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 =
         SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn)
-> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ XListTy GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy NoExtField
XListTy GhcRn
noExtField (SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [Id]
vs Type
ty)
      | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
promotedNilDataCon, [] <- [Type]
vis_tys
      = SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn)
-> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ XExplicitListTy GhcRn
-> PromotionFlag -> [LHsType GhcRn] -> HsType GhcRn
forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy NoExtField
XExplicitListTy GhcRn
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 :: LHsType GhcRn
hTy = SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [Id]
vs Type
ty1
        in case SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [Id]
vs Type
ty2 of
             LHsType GhcRn
tTy | L SrcSpan
_ (HsExplicitListTy XExplicitListTy GhcRn
_ PromotionFlag
IsPromoted [LHsType GhcRn]
tTy') <- LHsType GhcRn -> LHsType GhcRn
stripKindSig LHsType GhcRn
tTy
                 -> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn)
-> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ XExplicitListTy GhcRn
-> PromotionFlag -> [LHsType GhcRn] -> HsType GhcRn
forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy NoExtField
XExplicitListTy GhcRn
noExtField PromotionFlag
IsPromoted (LHsType GhcRn
hTy LHsType GhcRn -> [LHsType GhcRn] -> [LHsType GhcRn]
forall a. a -> [a] -> [a]
: [LHsType GhcRn]
tTy')
                 | Bool
otherwise
                 -> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn)
-> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ XOpTy GhcRn
-> LHsType GhcRn
-> Located (IdP GhcRn)
-> LHsType GhcRn
-> HsType GhcRn
forall pass.
XOpTy pass
-> LHsType pass
-> Located (IdP pass)
-> LHsType pass
-> HsType pass
HsOpTy NoExtField
XOpTy GhcRn
noExtField LHsType GhcRn
hTy (SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located Name) -> Located Name)
-> SrcSpanLess (Located Name) -> Located Name
forall a b. (a -> b) -> a -> b
$ TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc) LHsType 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
      = SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn)
-> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ XIParamTy GhcRn
-> Located HsIPName -> LHsType GhcRn -> HsType GhcRn
forall pass.
XIParamTy pass -> Located HsIPName -> LHsType pass -> HsType pass
HsIParamTy NoExtField
XIParamTy GhcRn
noExtField (SrcSpanLess (Located HsIPName) -> Located HsIPName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located HsIPName) -> Located HsIPName)
-> SrcSpanLess (Located HsIPName) -> Located HsIPName
forall a b. (a -> b) -> a -> b
$ FastString -> HsIPName
HsIPName FastString
x) (SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [Id]
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
      = SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn)
-> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ XOpTy GhcRn
-> LHsType GhcRn
-> Located (IdP GhcRn)
-> LHsType GhcRn
-> HsType GhcRn
forall pass.
XOpTy pass
-> LHsType pass
-> Located (IdP pass)
-> LHsType pass
-> HsType pass
HsOpTy NoExtField
XOpTy GhcRn
noExtField
                       (SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [Id]
vs Type
ty1)
                       (SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located Name)
Name
eqTyConName)
                       (SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [Id]
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] -> LHsType GhcRn
mk_app_tys (XOpTy GhcRn
-> LHsType GhcRn
-> Located (IdP GhcRn)
-> LHsType GhcRn
-> HsType GhcRn
forall pass.
XOpTy pass
-> LHsType pass
-> Located (IdP pass)
-> LHsType pass
-> HsType pass
HsOpTy NoExtField
XOpTy GhcRn
noExtField
                           (SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [Id]
vs Type
ty1)
                           (SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located Name) -> Located Name)
-> SrcSpanLess (Located Name) -> Located Name
forall a b. (a -> b) -> a -> b
$ TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc)
                           (SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [Id]
vs Type
ty2))
                   [Type]
tys_rest
      -- Most TyCons:
      | Bool
otherwise
      = HsType GhcRn -> [Type] -> LHsType GhcRn
mk_app_tys (XTyVar GhcRn
-> PromotionFlag -> Located (IdP GhcRn) -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar NoExtField
XTyVar GhcRn
noExtField PromotionFlag
prom (Located (IdP GhcRn) -> HsType GhcRn)
-> Located (IdP GhcRn) -> HsType GhcRn
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (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] -> LHsType GhcRn
mk_app_tys HsType GhcRn
ty_app [Type]
ty_args =
          (LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn)
-> LHsType GhcRn -> [LHsType GhcRn] -> LHsType GhcRn
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\LHsType GhcRn
t1 LHsType GhcRn
t2 -> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn)
-> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ XAppTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy NoExtField
XAppTy GhcRn
noExtField LHsType GhcRn
t1 LHsType GhcRn
t2)
                (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsType GhcRn
SrcSpanLess (LHsType GhcRn)
ty_app)
                ((Type -> LHsType GhcRn) -> [Type] -> [LHsType GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [Id]
vs) ([Type] -> [LHsType GhcRn]) -> [Type] -> [LHsType 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 :: Int
tys_len = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys
    vis_tys :: [Type]
vis_tys = TyCon -> [Type] -> [Type]
filterOutInvisibleTypes TyCon
tc [Type]
tys

    maybe_sig :: LHsType GhcRn -> LHsType GhcRn
    maybe_sig :: LHsType GhcRn -> LHsType GhcRn
maybe_sig LHsType GhcRn
ty'
      | Bool -> TyCon -> Int -> Bool
tyConAppNeedsKindSig Bool
False TyCon
tc Int
tys_len
      = let full_kind :: Type
full_kind  = HasDebugCallStack => Type -> Type
Type -> Type
typeKind (TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
tys)
            full_kind' :: LHsType GhcRn
full_kind' = SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [Id]
vs Type
full_kind
        in SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn)
-> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ XKindSig GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XKindSig pass -> LHsType pass -> LHsType pass -> HsType pass
HsKindSig NoExtField
XKindSig GhcRn
noExtField LHsType GhcRn
ty' LHsType GhcRn
full_kind'
      | Bool
otherwise = LHsType GhcRn
ty'

synifyType SynifyTypeState
_ [Id]
vs ty :: Type
ty@(AppTy {}) = let
  (Type
ty_head, [Type]
ty_args) = Type -> (Type, [Type])
splitAppTys Type
ty
  ty_head' :: LHsType GhcRn
ty_head' = SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [Id]
vs Type
ty_head
  ty_args' :: [LHsType GhcRn]
ty_args' = (Type -> LHsType GhcRn) -> [Type] -> [LHsType GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [Id]
vs) ([Type] -> [LHsType GhcRn]) -> [Type] -> [LHsType 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 ((ArgFlag -> Bool) -> [ArgFlag] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ArgFlag -> Bool
isVisibleArgFlag ([ArgFlag] -> [Bool]) -> [ArgFlag] -> [Bool]
forall a b. (a -> b) -> a -> b
$ Type -> [Type] -> [ArgFlag]
appTyArgFlags Type
ty_head [Type]
ty_args)
                          [Type]
ty_args
  in (LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn)
-> LHsType GhcRn -> [LHsType GhcRn] -> LHsType GhcRn
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\LHsType GhcRn
t1 LHsType GhcRn
t2 -> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn)
-> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ XAppTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy NoExtField
XAppTy GhcRn
noExtField LHsType GhcRn
t1 LHsType GhcRn
t2) LHsType GhcRn
ty_head' [LHsType GhcRn]
ty_args'
synifyType SynifyTypeState
s [Id]
vs funty :: Type
funty@(FunTy AnonArgFlag
InvisArg Type
_ Type
_) = SynifyTypeState -> ArgFlag -> [Id] -> Type -> LHsType GhcRn
synifyForAllType SynifyTypeState
s ArgFlag
Inferred [Id]
vs Type
funty
synifyType SynifyTypeState
_ [Id]
vs       (FunTy AnonArgFlag
VisArg Type
t1 Type
t2) = let
  s1 :: LHsType GhcRn
s1 = SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [Id]
vs Type
t1
  s2 :: LHsType GhcRn
s2 = SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [Id]
vs Type
t2
  in SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn)
-> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ XFunTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy NoExtField
XFunTy GhcRn
noExtField LHsType GhcRn
s1 LHsType GhcRn
s2
synifyType SynifyTypeState
s [Id]
vs forallty :: Type
forallty@(ForAllTy (Bndr Id
_ ArgFlag
argf) Type
_ty) =
  SynifyTypeState -> ArgFlag -> [Id] -> Type -> LHsType GhcRn
synifyForAllType SynifyTypeState
s ArgFlag
argf [Id]
vs Type
forallty

synifyType SynifyTypeState
_ [Id]
_ (LitTy TyLit
t) = SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn)
-> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$ XTyLit GhcRn -> HsTyLit -> HsType GhcRn
forall pass. XTyLit pass -> HsTyLit -> HsType pass
HsTyLit NoExtField
XTyLit GhcRn
noExtField (HsTyLit -> HsType GhcRn) -> HsTyLit -> HsType GhcRn
forall a b. (a -> b) -> a -> b
$ TyLit -> HsTyLit
synifyTyLit TyLit
t
synifyType SynifyTypeState
s [Id]
vs (CastTy Type
t KindCoercion
_) = SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
s [Id]
vs Type
t
synifyType SynifyTypeState
_ [Id]
_ (CoercionTy {}) = String -> LHsType GhcRn
forall a. HasCallStack => String -> a
error String
"synifyType:Coercion"

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

      sTy :: HsType GhcRn
sTy = HsForAllTy :: forall pass.
XForAllTy pass
-> ForallVisFlag
-> [LHsTyVarBndr pass]
-> LHsType pass
-> HsType pass
HsForAllTy { hst_fvf :: ForallVisFlag
hst_fvf = ArgFlag -> ForallVisFlag
argToForallVisFlag ArgFlag
argf
                       , hst_bndrs :: [LHsTyVarBndr GhcRn]
hst_bndrs = [LHsTyVarBndr GhcRn]
sTvs
                       , hst_xforall :: XForAllTy GhcRn
hst_xforall = NoExtField
XForAllTy GhcRn
noExtField
                       , hst_body :: LHsType GhcRn
hst_body  = SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsType GhcRn
SrcSpanLess (LHsType GhcRn)
sPhi }

      sTvs :: [LHsTyVarBndr GhcRn]
sTvs = (Id -> LHsTyVarBndr GhcRn) -> [Id] -> [LHsTyVarBndr GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map Id -> LHsTyVarBndr GhcRn
synifyTyVar [Id]
tvs

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

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

    -- Put a forall in if there are any type variables
    SynifyTypeState
WithinType
      | Bool -> Bool
not ([Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
tvs) -> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsType GhcRn
SrcSpanLess (LHsType GhcRn)
sTy
      | Bool
otherwise -> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsType GhcRn
SrcSpanLess (LHsType GhcRn)
sPhi

    SynifyTypeState
ImplicitizeForAll -> [TyCon]
-> [Id]
-> [Id]
-> [Type]
-> ([Id] -> Type -> LHsType GhcRn)
-> Type
-> LHsType GhcRn
implicitForAll [] [Id]
vs [Id]
tvs [Type]
ctx (SynifyTypeState -> [Id] -> Type -> LHsType 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
  -> [TyVar]          -- ^ 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]
-> [Id]
-> [Id]
-> [Type]
-> ([Id] -> Type -> LHsType GhcRn)
-> Type
-> LHsType GhcRn
implicitForAll [TyCon]
tycons [Id]
vs [Id]
tvs [Type]
ctx [Id] -> Type -> LHsType GhcRn
synInner Type
tau
  | (LHsTyVarBndr GhcRn -> Bool) -> [LHsTyVarBndr GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (HsTyVarBndr GhcRn -> Bool
forall pass. HsTyVarBndr pass -> Bool
isHsKindedTyVar (HsTyVarBndr GhcRn -> Bool)
-> (LHsTyVarBndr GhcRn -> HsTyVarBndr GhcRn)
-> LHsTyVarBndr GhcRn
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsTyVarBndr GhcRn -> HsTyVarBndr GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LHsTyVarBndr GhcRn]
sTvs = SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsType GhcRn
SrcSpanLess (LHsType GhcRn)
sTy
  | [Id]
tvs' [Id] -> [Id] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Id]
tvs                        = SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsType GhcRn
SrcSpanLess (LHsType GhcRn)
sTy
  | Bool
otherwise                          = SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsType GhcRn
SrcSpanLess (LHsType GhcRn)
sPhi
  where
  sRho :: LHsType GhcRn
sRho = [Id] -> Type -> LHsType GhcRn
synInner ([Id]
tvs' [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
vs) Type
tau
  sPhi :: HsType GhcRn
sPhi | [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
ctx = LHsType GhcRn -> SrcSpanLess (LHsType GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsType GhcRn
sRho
       | Bool
otherwise
       = HsQualTy :: forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy { hst_ctxt :: LHsContext GhcRn
hst_ctxt = [Type] -> LHsContext GhcRn
synifyCtx [Type]
ctx
                  , hst_xqual :: XQualTy GhcRn
hst_xqual = NoExtField
XQualTy GhcRn
noExtField
                  , hst_body :: LHsType GhcRn
hst_body = [Id] -> Type -> LHsType GhcRn
synInner ([Id]
tvs' [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
vs) Type
tau }
  sTy :: HsType GhcRn
sTy = HsForAllTy :: forall pass.
XForAllTy pass
-> ForallVisFlag
-> [LHsTyVarBndr pass]
-> LHsType pass
-> HsType pass
HsForAllTy { hst_fvf :: ForallVisFlag
hst_fvf = ForallVisFlag
ForallInvis
                   , hst_bndrs :: [LHsTyVarBndr GhcRn]
hst_bndrs = [LHsTyVarBndr GhcRn]
sTvs
                   , hst_xforall :: XForAllTy GhcRn
hst_xforall = NoExtField
XForAllTy GhcRn
noExtField
                   , hst_body :: LHsType GhcRn
hst_body = SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsType GhcRn
SrcSpanLess (LHsType GhcRn)
sPhi }

  no_kinds_needed :: VarSet
no_kinds_needed = [TyCon] -> Type -> VarSet
noKindTyVars [TyCon]
tycons Type
tau
  sTvs :: [LHsTyVarBndr GhcRn]
sTvs = (Id -> LHsTyVarBndr GhcRn) -> [Id] -> [LHsTyVarBndr GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (VarSet -> Id -> LHsTyVarBndr GhcRn
synifyTyVar' VarSet
no_kinds_needed) [Id]
tvs

  -- Figure out what the type variable order would be inferred in the
  -- absence of an explicit forall
  tvs' :: [Id]
tvs' = VarSet -> [Type] -> [Id]
orderedFVs ([Id] -> VarSet
mkVarSet [Id]
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 Id
var)
  | Type -> Bool
isLiftedTypeKind (Id -> Type
tyVarKind Id
var) = Id -> VarSet
unitVarSet Id
var
noKindTyVars [TyCon]
ts Type
ty
  | (Type
f, [Type]
xs) <- Type -> (Type, [Type])
splitAppTys Type
ty
  , Bool -> Bool
not ([Type] -> 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 Id
var | ([Type]
xsKinds, Type
outKind) <- Type -> ([Type], Type)
splitFunTys (Id -> Type
tyVarKind Id
var)
                             , [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
                             -> Id -> VarSet
unitVarSet Id
var
                 TyConApp TyCon
t [Type]
ks | TyCon
t TyCon -> [TyCon] -> 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
                               -> [Id] -> VarSet
mkVarSet [ Id
v | TyVarTy Id
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 Id ArgFlag
_ Type
t) = [TyCon] -> Type -> VarSet
noKindTyVars [TyCon]
ts Type
t
noKindTyVars [TyCon]
ts (FunTy AnonArgFlag
_ Type
t1 Type
t2) = [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

synifyPatSynType :: PatSyn -> LHsType GhcRn
synifyPatSynType :: PatSyn -> LHsType GhcRn
synifyPatSynType PatSyn
ps =
  let ([Id]
univ_tvs, [Type]
req_theta, [Id]
ex_tvs, [Type]
prov_theta, [Type]
arg_tys, Type
res_ty) = PatSyn -> ([Id], [Type], [Id], [Type], [Type], Type)
patSynSig 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 (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
req_theta
                 , Bool -> Bool
not ([Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
prov_theta Bool -> Bool -> Bool
&& [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
ex_tvs)
                 = [Type
unitTy]
                 | Bool
otherwise = [Type]
req_theta

  in [TyCon]
-> [Id]
-> [Id]
-> [Type]
-> ([Id] -> Type -> LHsType GhcRn)
-> Type
-> LHsType GhcRn
implicitForAll [TyCon]
ts [] ([Id]
univ_tvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
ex_tvs) [Type]
req_theta'
       (\[Id]
vs -> [TyCon]
-> [Id]
-> [Id]
-> [Type]
-> ([Id] -> Type -> LHsType GhcRn)
-> Type
-> LHsType GhcRn
implicitForAll [TyCon]
ts [Id]
vs [] [Type]
prov_theta (SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType))
       ([Type] -> Type -> Type
mkVisFunTys [Type]
arg_tys Type
res_ty)

synifyTyLit :: TyLit -> HsTyLit
synifyTyLit :: TyLit -> HsTyLit
synifyTyLit (NumTyLit Integer
n) = SourceText -> Integer -> HsTyLit
HsNumTy SourceText
NoSourceText Integer
n
synifyTyLit (StrTyLit FastString
s) = SourceText -> FastString -> HsTyLit
HsStrTy SourceText
NoSourceText FastString
s

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

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

synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn
synifyInstHead :: ([Id], [Type], Class, [Type]) -> InstHead GhcRn
synifyInstHead ([Id]
vs, [Type]
preds, Class
cls, [Type]
types) = InstHead GhcRn -> InstHead GhcRn
specializeInstHead (InstHead GhcRn -> InstHead GhcRn)
-> InstHead GhcRn -> InstHead GhcRn
forall a b. (a -> b) -> a -> b
$ InstHead :: forall name.
IdP name -> [HsType name] -> InstType name -> InstHead name
InstHead
    { ihdClsName :: IdP GhcRn
ihdClsName = Class -> Name
forall a. NamedThing a => a -> Name
getName Class
cls
    , ihdTypes :: [HsType GhcRn]
ihdTypes = (LHsType GhcRn -> HsType GhcRn)
-> [LHsType GhcRn] -> [HsType GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcRn -> HsType GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [LHsType GhcRn]
annot_ts
    , ihdInstType :: InstType GhcRn
ihdInstType = ClassInst :: forall name.
[HsType name]
-> LHsQTyVars name
-> [Sig name]
-> [PseudoFamilyDecl name]
-> InstType name
ClassInst
        { clsiCtx :: [HsType GhcRn]
clsiCtx = (Type -> HsType GhcRn) -> [Type] -> [HsType GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (LHsType GhcRn -> HsType GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LHsType GhcRn -> HsType GhcRn)
-> (Type -> LHsType GhcRn) -> Type -> HsType GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType []) [Type]
preds
        , clsiTyVars :: LHsQTyVars GhcRn
clsiTyVars = [Id] -> LHsQTyVars GhcRn
synifyTyVars (TyCon -> [Id]
tyConVisibleTyVars TyCon
cls_tycon)
        , clsiSigs :: [Sig GhcRn]
clsiSigs = (Id -> Sig GhcRn) -> [Id] -> [Sig GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Sig GhcRn
synifyClsIdSig ([Id] -> [Sig GhcRn]) -> [Id] -> [Sig GhcRn]
forall a b. (a -> b) -> a -> b
$ Class -> [Id]
classMethods Class
cls
        , clsiAssocTys :: [PseudoFamilyDecl GhcRn]
clsiAssocTys = do
            (Right (FamDecl XFamDecl GhcRn
_ FamilyDecl GhcRn
fam)) <- (TyCon -> Either String (TyClDecl GhcRn))
-> [TyCon] -> [Either String (TyClDecl GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (PrintRuntimeReps
-> Maybe (CoAxiom Any) -> TyCon -> Either String (TyClDecl GhcRn)
forall (br :: BranchFlag).
PrintRuntimeReps
-> Maybe (CoAxiom br) -> TyCon -> Either String (TyClDecl GhcRn)
synifyTyCon PrintRuntimeReps
HideRuntimeRep Maybe (CoAxiom Any)
forall a. Maybe a
Nothing)
                                           (Class -> [TyCon]
classATs Class
cls)
            PseudoFamilyDecl GhcRn -> [PseudoFamilyDecl GhcRn]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PseudoFamilyDecl GhcRn -> [PseudoFamilyDecl GhcRn])
-> PseudoFamilyDecl GhcRn -> [PseudoFamilyDecl GhcRn]
forall a b. (a -> b) -> a -> b
$ FamilyDecl GhcRn -> PseudoFamilyDecl GhcRn
forall (p :: Pass).
FamilyDecl (GhcPass p) -> PseudoFamilyDecl (GhcPass p)
mkPseudoFamilyDecl FamilyDecl GhcRn
fam
        }
    }
  where
    cls_tycon :: TyCon
cls_tycon = Class -> TyCon
classTyCon Class
cls
    ts :: [Type]
ts  = TyCon -> [Type] -> [Type]
filterOutInvisibleTypes TyCon
cls_tycon [Type]
types
    ts' :: [LHsType GhcRn]
ts' = (Type -> LHsType GhcRn) -> [Type] -> [LHsType GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [Id]
vs) [Type]
ts
    annot_ts :: [LHsType GhcRn]
annot_ts = (Bool -> Type -> LHsType GhcRn -> LHsType GhcRn)
-> [Bool] -> [Type] -> [LHsType GhcRn] -> [LHsType GhcRn]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Bool -> Type -> LHsType GhcRn -> LHsType GhcRn
annotHsType [Bool]
args_poly [Type]
ts [LHsType GhcRn]
ts'
    args_poly :: [Bool]
args_poly = TyCon -> [Bool]
tyConArgsPolyKinded TyCon
cls_tycon
    synifyClsIdSig :: Id -> Sig GhcRn
synifyClsIdSig = PrintRuntimeReps -> SynifyTypeState -> [Id] -> Id -> Sig GhcRn
synifyIdSig PrintRuntimeReps
ShowRuntimeRep SynifyTypeState
DeleteTopLevelQuantification [Id]
vs

-- Convert a family instance, this could be a type family or data family
synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead GhcRn)
synifyFamInst :: FamInst -> Bool -> Either String (InstHead GhcRn)
synifyFamInst FamInst
fi Bool
opaque = do
    InstType GhcRn
ityp' <- FamFlavor -> Either String (InstType GhcRn)
ityp FamFlavor
fam_flavor
    InstHead GhcRn -> Either String (InstHead GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return InstHead :: forall name.
IdP name -> [HsType name] -> InstType name -> InstHead name
InstHead
        { ihdClsName :: IdP GhcRn
ihdClsName = FamInst -> Name
fi_fam FamInst
fi
        , ihdTypes :: [HsType GhcRn]
ihdTypes = (LHsType GhcRn -> HsType GhcRn)
-> [LHsType GhcRn] -> [HsType GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcRn -> HsType GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [LHsType GhcRn]
annot_ts
        , ihdInstType :: InstType GhcRn
ihdInstType = InstType GhcRn
ityp'
        }
  where
    ityp :: FamFlavor -> Either String (InstType GhcRn)
ityp FamFlavor
SynFamilyInst | Bool
opaque = InstType GhcRn -> Either String (InstType GhcRn)
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 (m :: * -> *) a. Monad m => a -> m a
return (InstType GhcRn -> Either String (InstType GhcRn))
-> (LHsType GhcRn -> InstType GhcRn)
-> LHsType 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)
-> (LHsType GhcRn -> Maybe (HsType GhcRn))
-> LHsType 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))
-> (LHsType GhcRn -> HsType GhcRn)
-> LHsType GhcRn
-> Maybe (HsType GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType GhcRn -> HsType GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LHsType GhcRn -> Either String (InstType GhcRn))
-> LHsType GhcRn -> Either String (InstType GhcRn)
forall a b. (a -> b) -> a -> b
$ SynifyTypeState -> [Id] -> Type -> LHsType 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 TcInstDcls in GHC
      | DataFamilyInst TyCon
rep_tc <- FamFlavor
fam_flavor
      = let (TyCon
_, [Type]
rep_tc_args) = Type -> (TyCon, [Type])
splitTyConApp Type
fam_rhs
            etad_tyvars :: [Id]
etad_tyvars      = [Type] -> [Id] -> [Id]
forall b a. [b] -> [a] -> [a]
dropList [Type]
rep_tc_args ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ TyCon -> [Id]
tyConTyVars TyCon
rep_tc
            etad_tys :: [Type]
etad_tys         = [Id] -> [Type]
mkTyVarTys [Id]
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] -> [LHsType GhcRn]
synifyTypes = (Type -> LHsType GhcRn) -> [Type] -> [LHsType GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (SynifyTypeState -> [Id] -> Type -> LHsType GhcRn
synifyType SynifyTypeState
WithinType [])
    ts' :: [LHsType GhcRn]
ts' = [Type] -> [LHsType GhcRn]
synifyTypes [Type]
ts
    annot_ts :: [LHsType GhcRn]
annot_ts = (Bool -> Type -> LHsType GhcRn -> LHsType GhcRn)
-> [Bool] -> [Type] -> [LHsType GhcRn] -> [LHsType GhcRn]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Bool -> Type -> LHsType GhcRn -> LHsType GhcRn
annotHsType [Bool]
args_poly [Type]
ts [LHsType 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.tcSplitSigmaTySameVis' that preserves type synonyms.
--
-- See Note [Invariant: Never expand type synonyms]
tcSplitSigmaTySameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVar], ThetaType, Type)
tcSplitSigmaTySameVisPreserveSynonyms :: ArgFlag -> Type -> ([Id], [Type], Type)
tcSplitSigmaTySameVisPreserveSynonyms ArgFlag
argf Type
ty =
    case ArgFlag -> Type -> ([Id], Type)
tcSplitForAllTysSameVisPreserveSynonyms ArgFlag
argf Type
ty of
      ([Id]
tvs, Type
rho) -> case Type -> ([Type], Type)
tcSplitPhiTyPreserveSynonyms Type
rho of
        ([Type]
theta, Type
tau) -> ([Id]
tvs, [Type]
theta, Type
tau)

-- | See Note [Invariant: Never expand type synonyms]
tcSplitForAllTysSameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVar], Type)
tcSplitForAllTysSameVisPreserveSynonyms :: ArgFlag -> Type -> ([Id], Type)
tcSplitForAllTysSameVisPreserveSynonyms ArgFlag
supplied_argf Type
ty = Type -> Type -> [Id] -> ([Id], Type)
split Type
ty Type
ty []
  where
    split :: Type -> Type -> [Id] -> ([Id], Type)
split Type
_       (ForAllTy (Bndr Id
tv ArgFlag
argf) Type
ty') [Id]
tvs
      | ArgFlag
argf ArgFlag -> ArgFlag -> Bool
`sameVis` ArgFlag
supplied_argf                = Type -> Type -> [Id] -> ([Id], Type)
split Type
ty' Type
ty' (Id
tvId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
tvs)
    split Type
orig_ty Type
_                             [Id]
tvs = ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
tvs, Type
orig_ty)

-- | 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 AnonArgFlag
InvisArg Type
arg Type
res) = (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