{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

module Haddock.Interface.Specialize
    ( specializeInstHead
    ) where


import Haddock.GhcUtils ( hsTyVarBndrName )
import Haddock.Syb
import Haddock.Types

import GHC
import Name
import FastString
import TysPrim ( funTyConName )
import TysWiredIn ( listTyConName )

import Control.Monad
import Control.Monad.Trans.State

import Data.Data
import qualified Data.List as List
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set

-- | Instantiate all occurrences of given names with corresponding types.
specialize :: Data a => [(Name, HsType GhcRn)] -> a -> a
specialize :: [(Name, HsType GhcRn)] -> a -> a
specialize [(Name, HsType GhcRn)]
specs = Map Name (HsType GhcRn) -> a -> a
forall x. Data x => Map Name (HsType GhcRn) -> x -> x
go Map Name (HsType GhcRn)
spec_map0
  where
    go :: forall x. Data x => Map Name (HsType GhcRn) -> x -> x
    go :: Map Name (HsType GhcRn) -> x -> x
go Map Name (HsType GhcRn)
spec_map = Typeable Name =>
(forall a. Data a => a -> a) -> forall a. Data a => a -> a
forall t.
Typeable t =>
(forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhereButType @Name ((forall a. Data a => a -> a) -> forall a. Data a => a -> a)
-> (forall a. Data a => a -> a) -> forall a. Data a => a -> a
forall a b. (a -> b) -> a -> b
$ (HsType GhcRn -> HsType GhcRn) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT ((HsType GhcRn -> HsType GhcRn) -> a -> a)
-> (HsType GhcRn -> HsType GhcRn) -> a -> a
forall a b. (a -> b) -> a -> b
$ HsType GhcRn -> HsType GhcRn
sugar (HsType GhcRn -> HsType GhcRn)
-> (HsType GhcRn -> HsType GhcRn) -> HsType GhcRn -> HsType GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType GhcRn -> HsType GhcRn
forall name. HsType name -> HsType name
strip_kind_sig (HsType GhcRn -> HsType GhcRn)
-> (HsType GhcRn -> HsType GhcRn) -> HsType GhcRn -> HsType GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name (HsType GhcRn) -> HsType GhcRn -> HsType GhcRn
specialize_ty_var Map Name (HsType GhcRn)
spec_map

    strip_kind_sig :: HsType name -> HsType name
    strip_kind_sig :: HsType name -> HsType name
strip_kind_sig (HsKindSig XKindSig name
_ (L SrcSpan
_ HsType name
t) GenLocated SrcSpan (HsType name)
_) = HsType name
t
    strip_kind_sig HsType name
typ = HsType name
typ

    specialize_ty_var :: Map Name (HsType GhcRn) -> HsType GhcRn -> HsType GhcRn
    specialize_ty_var :: Map Name (HsType GhcRn) -> HsType GhcRn -> HsType GhcRn
specialize_ty_var Map Name (HsType GhcRn)
spec_map (HsTyVar XTyVar GhcRn
_ PromotionFlag
_ (L SrcSpan
_ IdP GhcRn
name'))
      | Just HsType GhcRn
t <- Name -> Map Name (HsType GhcRn) -> Maybe (HsType GhcRn)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup IdP GhcRn
Name
name' Map Name (HsType GhcRn)
spec_map = HsType GhcRn
t
    specialize_ty_var Map Name (HsType GhcRn)
_ HsType GhcRn
typ = HsType GhcRn
typ

    -- This is a tricky recursive definition. By adding in the specializations
    -- one by one, we should avoid infinite loops.
    spec_map0 :: Map Name (HsType GhcRn)
spec_map0 = ((Name, HsType GhcRn)
 -> Map Name (HsType GhcRn) -> Map Name (HsType GhcRn))
-> Map Name (HsType GhcRn)
-> [(Name, HsType GhcRn)]
-> Map Name (HsType GhcRn)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Name
n,HsType GhcRn
t) Map Name (HsType GhcRn)
acc -> Name
-> HsType GhcRn
-> Map Name (HsType GhcRn)
-> Map Name (HsType GhcRn)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
n (Map Name (HsType GhcRn) -> HsType GhcRn -> HsType GhcRn
forall x. Data x => Map Name (HsType GhcRn) -> x -> x
go Map Name (HsType GhcRn)
acc HsType GhcRn
t) Map Name (HsType GhcRn)
acc) Map Name (HsType GhcRn)
forall a. Monoid a => a
mempty [(Name, HsType GhcRn)]
specs

{-# SPECIALIZE specialize :: [(Name, HsType GhcRn)] -> HsType GhcRn -> HsType GhcRn #-}

-- | Instantiate given binders with corresponding types.
--
-- Again, it is just a convenience function around 'specialize'. Note that
-- length of type list should be the same as the number of binders.
specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn
specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn
specializeTyVarBndrs LHsQTyVars GhcRn
bndrs [HsType GhcRn]
typs = [(Name, HsType GhcRn)] -> HsType GhcRn -> HsType GhcRn
forall a. Data a => [(Name, HsType GhcRn)] -> a -> a
specialize ([(Name, HsType GhcRn)] -> HsType GhcRn -> HsType GhcRn)
-> [(Name, HsType GhcRn)] -> HsType GhcRn -> HsType GhcRn
forall a b. (a -> b) -> a -> b
$ [Name] -> [HsType GhcRn] -> [(Name, HsType GhcRn)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
bndrs' [HsType GhcRn]
typs
  where
    bndrs' :: [Name]
bndrs' = (LHsTyVarBndr GhcRn -> Name) -> [LHsTyVarBndr GhcRn] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (HsTyVarBndr GhcRn -> Name
forall n. (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr n -> IdP n
hsTyVarBndrName (HsTyVarBndr GhcRn -> Name)
-> (LHsTyVarBndr GhcRn -> HsTyVarBndr GhcRn)
-> LHsTyVarBndr GhcRn
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsTyVarBndr GhcRn -> HsTyVarBndr GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) ([LHsTyVarBndr GhcRn] -> [Name])
-> (LHsQTyVars GhcRn -> [LHsTyVarBndr GhcRn])
-> LHsQTyVars GhcRn
-> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsQTyVars GhcRn -> [LHsTyVarBndr GhcRn]
forall pass. LHsQTyVars pass -> [LHsTyVarBndr pass]
hsq_explicit (LHsQTyVars GhcRn -> [Name]) -> LHsQTyVars GhcRn -> [Name]
forall a b. (a -> b) -> a -> b
$ LHsQTyVars GhcRn
bndrs



specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn]
                           -> PseudoFamilyDecl GhcRn
                           -> PseudoFamilyDecl GhcRn
specializePseudoFamilyDecl :: LHsQTyVars GhcRn
-> [HsType GhcRn]
-> PseudoFamilyDecl GhcRn
-> PseudoFamilyDecl GhcRn
specializePseudoFamilyDecl LHsQTyVars GhcRn
bndrs [HsType GhcRn]
typs PseudoFamilyDecl GhcRn
decl =
  PseudoFamilyDecl GhcRn
decl {pfdTyVars :: [LHsType GhcRn]
pfdTyVars = (LHsType GhcRn -> LHsType GhcRn)
-> [LHsType GhcRn] -> [LHsType GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map ((HsType GhcRn -> HsType GhcRn) -> LHsType GhcRn -> LHsType GhcRn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn
specializeTyVarBndrs LHsQTyVars GhcRn
bndrs [HsType GhcRn]
typs)) (PseudoFamilyDecl GhcRn -> [LHsType GhcRn]
forall name. PseudoFamilyDecl name -> [LHsType name]
pfdTyVars PseudoFamilyDecl GhcRn
decl)}

specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn]
              -> Sig GhcRn
              -> Sig GhcRn
specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] -> Sig GhcRn -> Sig GhcRn
specializeSig LHsQTyVars GhcRn
bndrs [HsType GhcRn]
typs (TypeSig XTypeSig GhcRn
_ [GenLocated SrcSpan (IdP GhcRn)]
lnames LHsSigWcType GhcRn
typ) =
  XTypeSig GhcRn
-> [GenLocated SrcSpan (IdP GhcRn)]
-> LHsSigWcType GhcRn
-> Sig GhcRn
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
TypeSig NoExtField
XTypeSig GhcRn
noExtField [GenLocated SrcSpan (IdP GhcRn)]
lnames (LHsSigWcType GhcRn
typ {hswc_body :: LHsSigType GhcRn
hswc_body = (LHsSigWcType GhcRn -> LHsSigType GhcRn
forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body LHsSigWcType GhcRn
typ) {hsib_body :: LHsType GhcRn
hsib_body = SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsType GhcRn
SrcSpanLess (LHsType GhcRn)
typ'}})
  where
    true_type :: HsType GhcRn
    true_type :: HsType GhcRn
true_type = LHsType GhcRn -> SrcSpanLess (LHsType GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LHsSigWcType GhcRn -> LHsType GhcRn
forall pass. LHsSigWcType pass -> LHsType pass
hsSigWcType LHsSigWcType GhcRn
typ)
    typ' :: HsType GhcRn
    typ' :: HsType GhcRn
typ' = Set Name -> HsType GhcRn -> HsType GhcRn
rename Set Name
fv (HsType GhcRn -> HsType GhcRn) -> HsType GhcRn -> HsType GhcRn
forall a b. (a -> b) -> a -> b
$ LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn
specializeTyVarBndrs LHsQTyVars GhcRn
bndrs [HsType GhcRn]
typs HsType GhcRn
true_type
    fv :: Set Name
fv = (Set Name -> Set Name -> Set Name)
-> Set Name -> [Set Name] -> Set Name
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Name
forall a. Set a
Set.empty ([Set Name] -> Set Name)
-> ([HsType GhcRn] -> [Set Name]) -> [HsType GhcRn] -> Set Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsType GhcRn -> Set Name) -> [HsType GhcRn] -> [Set Name]
forall a b. (a -> b) -> [a] -> [b]
map HsType GhcRn -> Set Name
freeVariables ([HsType GhcRn] -> Set Name) -> [HsType GhcRn] -> Set Name
forall a b. (a -> b) -> a -> b
$ [HsType GhcRn]
typs
specializeSig LHsQTyVars GhcRn
_ [HsType GhcRn]
_ Sig GhcRn
sig = Sig GhcRn
sig


-- | Make all details of instance head (signatures, associated types)
-- specialized to that particular instance type.
specializeInstHead :: InstHead GhcRn -> InstHead GhcRn
specializeInstHead :: InstHead GhcRn -> InstHead GhcRn
specializeInstHead ihd :: InstHead GhcRn
ihd@InstHead { ihdInstType :: forall name. InstHead name -> InstType name
ihdInstType = clsi :: InstType GhcRn
clsi@ClassInst { [Sig GhcRn]
[HsType GhcRn]
[PseudoFamilyDecl GhcRn]
LHsQTyVars GhcRn
clsiAssocTys :: forall name. InstType name -> [PseudoFamilyDecl name]
clsiSigs :: forall name. InstType name -> [Sig name]
clsiTyVars :: forall name. InstType name -> LHsQTyVars name
clsiCtx :: forall name. InstType name -> [HsType name]
clsiAssocTys :: [PseudoFamilyDecl GhcRn]
clsiSigs :: [Sig GhcRn]
clsiTyVars :: LHsQTyVars GhcRn
clsiCtx :: [HsType GhcRn]
.. }, [HsType GhcRn]
IdP GhcRn
ihdTypes :: forall name. InstHead name -> [HsType name]
ihdClsName :: forall name. InstHead name -> IdP name
ihdTypes :: [HsType GhcRn]
ihdClsName :: IdP GhcRn
.. } =
    InstHead GhcRn
ihd { ihdInstType :: InstType GhcRn
ihdInstType = InstType GhcRn
instType' }
  where
    instType' :: InstType GhcRn
instType' = InstType GhcRn
clsi
        { clsiSigs :: [Sig GhcRn]
clsiSigs = (Sig GhcRn -> Sig GhcRn) -> [Sig GhcRn] -> [Sig GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map Sig GhcRn -> Sig GhcRn
specializeSig' [Sig GhcRn]
clsiSigs
        , clsiAssocTys :: [PseudoFamilyDecl GhcRn]
clsiAssocTys = (PseudoFamilyDecl GhcRn -> PseudoFamilyDecl GhcRn)
-> [PseudoFamilyDecl GhcRn] -> [PseudoFamilyDecl GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map PseudoFamilyDecl GhcRn -> PseudoFamilyDecl GhcRn
specializeFamilyDecl' [PseudoFamilyDecl GhcRn]
clsiAssocTys
        }
    specializeSig' :: Sig GhcRn -> Sig GhcRn
specializeSig' = LHsQTyVars GhcRn -> [HsType GhcRn] -> Sig GhcRn -> Sig GhcRn
specializeSig LHsQTyVars GhcRn
clsiTyVars [HsType GhcRn]
ihdTypes
    specializeFamilyDecl' :: PseudoFamilyDecl GhcRn -> PseudoFamilyDecl GhcRn
specializeFamilyDecl' = LHsQTyVars GhcRn
-> [HsType GhcRn]
-> PseudoFamilyDecl GhcRn
-> PseudoFamilyDecl GhcRn
specializePseudoFamilyDecl LHsQTyVars GhcRn
clsiTyVars [HsType GhcRn]
ihdTypes
specializeInstHead InstHead GhcRn
ihd = InstHead GhcRn
ihd


-- | Make given type use tuple and list literals where appropriate.
--
-- After applying 'specialize' function some terms may not use idiomatic list
-- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This
-- can be fixed using 'sugar' function, that will turn such types into @[a]@
-- and @(a, b, c)@.
sugar :: HsType GhcRn -> HsType GhcRn
sugar :: HsType GhcRn -> HsType GhcRn
sugar = HsType GhcRn -> HsType GhcRn
forall (p :: Pass).
NamedThing (IdP (GhcPass p)) =>
HsType (GhcPass p) -> HsType (GhcPass p)
sugarOperators (HsType GhcRn -> HsType GhcRn)
-> (HsType GhcRn -> HsType GhcRn) -> HsType GhcRn -> HsType GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType GhcRn -> HsType GhcRn
forall (p :: Pass).
NamedThing (IdP (GhcPass p)) =>
HsType (GhcPass p) -> HsType (GhcPass p)
sugarTuples (HsType GhcRn -> HsType GhcRn)
-> (HsType GhcRn -> HsType GhcRn) -> HsType GhcRn -> HsType GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType GhcRn -> HsType GhcRn
forall (p :: Pass).
NamedThing (IdP (GhcPass p)) =>
HsType (GhcPass p) -> HsType (GhcPass p)
sugarLists

sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
sugarLists :: HsType (GhcPass p) -> HsType (GhcPass p)
sugarLists (HsAppTy XAppTy (GhcPass p)
_ (L SrcSpan
_ (HsTyVar XTyVar (GhcPass p)
_ PromotionFlag
_ (L SrcSpan
_ IdP (GhcPass p)
name))) GenLocated SrcSpan (HsType (GhcPass p))
ltyp)
    | IdP (GhcPass p) -> Name
forall a. NamedThing a => a -> Name
getName IdP (GhcPass p)
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
listTyConName = XListTy (GhcPass p)
-> GenLocated SrcSpan (HsType (GhcPass p)) -> HsType (GhcPass p)
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy NoExtField
XListTy (GhcPass p)
noExtField GenLocated SrcSpan (HsType (GhcPass p))
ltyp
sugarLists HsType (GhcPass p)
typ = HsType (GhcPass p)
typ


sugarTuples :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
sugarTuples :: HsType (GhcPass p) -> HsType (GhcPass p)
sugarTuples HsType (GhcPass p)
typ =
    [LHsType (GhcPass p)] -> HsType (GhcPass p) -> HsType (GhcPass p)
aux [] HsType (GhcPass p)
typ
  where
    aux :: [LHsType (GhcPass p)] -> HsType (GhcPass p) -> HsType (GhcPass p)
aux [LHsType (GhcPass p)]
apps (HsAppTy XAppTy (GhcPass p)
_ (L SrcSpan
_ HsType (GhcPass p)
ftyp) LHsType (GhcPass p)
atyp) = [LHsType (GhcPass p)] -> HsType (GhcPass p) -> HsType (GhcPass p)
aux (LHsType (GhcPass p)
atypLHsType (GhcPass p)
-> [LHsType (GhcPass p)] -> [LHsType (GhcPass p)]
forall a. a -> [a] -> [a]
:[LHsType (GhcPass p)]
apps) HsType (GhcPass p)
ftyp
    aux [LHsType (GhcPass p)]
apps (HsParTy XParTy (GhcPass p)
_ (L SrcSpan
_ HsType (GhcPass p)
typ')) = [LHsType (GhcPass p)] -> HsType (GhcPass p) -> HsType (GhcPass p)
aux [LHsType (GhcPass p)]
apps HsType (GhcPass p)
typ'
    aux [LHsType (GhcPass p)]
apps (HsTyVar XTyVar (GhcPass p)
_ PromotionFlag
_ (L SrcSpan
_ IdP (GhcPass p)
name))
        | Name -> Bool
isBuiltInSyntax Name
name' Bool -> Bool -> Bool
&& Bool
suitable = XTupleTy (GhcPass p)
-> HsTupleSort -> [LHsType (GhcPass p)] -> HsType (GhcPass p)
forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy NoExtField
XTupleTy (GhcPass p)
noExtField HsTupleSort
HsBoxedTuple [LHsType (GhcPass p)]
apps
      where
        name' :: Name
name' = IdP (GhcPass p) -> Name
forall a. NamedThing a => a -> Name
getName IdP (GhcPass p)
name
        strName :: String
strName = IdP (GhcPass p) -> String
forall a. NamedThing a => a -> String
getOccString IdP (GhcPass p)
name
        suitable :: Bool
suitable = case String -> Maybe Int
parseTupleArity String
strName of
            Just Int
arity -> Int
arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [LHsType (GhcPass p)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsType (GhcPass p)]
apps
            Maybe Int
Nothing -> Bool
False
    aux [LHsType (GhcPass p)]
_ HsType (GhcPass p)
_ = HsType (GhcPass p)
typ


sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
sugarOperators :: HsType (GhcPass p) -> HsType (GhcPass p)
sugarOperators (HsAppTy XAppTy (GhcPass p)
_ (L SrcSpan
_ (HsAppTy XAppTy (GhcPass p)
_ (L SrcSpan
_ (HsTyVar XTyVar (GhcPass p)
_ PromotionFlag
_ (L SrcSpan
l IdP (GhcPass p)
name))) GenLocated SrcSpan (HsType (GhcPass p))
la)) GenLocated SrcSpan (HsType (GhcPass p))
lb)
    | OccName -> Bool
isSymOcc (OccName -> Bool) -> OccName -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
name' = GenLocated SrcSpan (HsType (GhcPass p))
-> GenLocated SrcSpan (IdP (GhcPass p))
-> GenLocated SrcSpan (HsType (GhcPass p))
-> HsType (GhcPass p)
forall (p :: Pass).
LHsType (GhcPass p)
-> Located (IdP (GhcPass p))
-> LHsType (GhcPass p)
-> HsType (GhcPass p)
mkHsOpTy GenLocated SrcSpan (HsType (GhcPass p))
la (SrcSpan -> IdP (GhcPass p) -> GenLocated SrcSpan (IdP (GhcPass p))
forall l e. l -> e -> GenLocated l e
L SrcSpan
l IdP (GhcPass p)
name) GenLocated SrcSpan (HsType (GhcPass p))
lb
    | Name
funTyConName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name' = XFunTy (GhcPass p)
-> GenLocated SrcSpan (HsType (GhcPass p))
-> GenLocated SrcSpan (HsType (GhcPass p))
-> HsType (GhcPass p)
forall pass.
XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy NoExtField
XFunTy (GhcPass p)
noExtField GenLocated SrcSpan (HsType (GhcPass p))
la GenLocated SrcSpan (HsType (GhcPass p))
lb
  where
    name' :: Name
name' = IdP (GhcPass p) -> Name
forall a. NamedThing a => a -> Name
getName IdP (GhcPass p)
name
sugarOperators HsType (GhcPass p)
typ = HsType (GhcPass p)
typ


-- | Compute arity of given tuple operator.
--
-- >>> parseTupleArity "(,,)"
-- Just 3
--
-- >>> parseTupleArity "(,,,,)"
-- Just 5
--
-- >>> parseTupleArity "abc"
-- Nothing
--
-- >>> parseTupleArity "()"
-- Nothing
parseTupleArity :: String -> Maybe Int
parseTupleArity :: String -> Maybe Int
parseTupleArity (Char
'(':String
commas) = do
    Int
n <- String -> Maybe Int
forall b. Num b => String -> Maybe b
parseCommas String
commas
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
    Int -> Maybe Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
  where
    parseCommas :: String -> Maybe b
parseCommas (Char
',':String
rest) = (b -> b -> b
forall a. Num a => a -> a -> a
+ b
1) (b -> b) -> Maybe b -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe b
parseCommas String
rest
    parseCommas String
")" = b -> Maybe b
forall a. a -> Maybe a
Just b
0
    parseCommas String
_ = Maybe b
forall a. Maybe a
Nothing
parseTupleArity String
_ = Maybe Int
forall a. Maybe a
Nothing


-- | Haskell AST type representation.
--
-- This type is used for renaming (more below), essentially the ambiguous (!)
-- version of 'Name'. So, why is this 'FastString' instead of 'OccName'? Well,
-- it was 'OccName' before, but turned out that 'OccName' sometimes also
-- contains namespace information, differentiating visually same types.
--
-- And 'FastString' is used because it is /visual/ part of 'OccName' - it is
-- not converted to 'String' or alike to avoid new allocations. Additionally,
-- since it is stored mostly in 'Set', fast comparison of 'FastString' is also
-- quite nice.
type NameRep = FastString

getNameRep :: NamedThing name => name -> NameRep
getNameRep :: name -> NameRep
getNameRep = name -> NameRep
forall a. NamedThing a => a -> NameRep
getOccFS

nameRepString :: NameRep -> String
nameRepString :: NameRep -> String
nameRepString = NameRep -> String
unpackFS

stringNameRep :: String -> NameRep
stringNameRep :: String -> NameRep
stringNameRep = String -> NameRep
mkFastString

setInternalNameRep :: SetName name => NameRep -> name -> name
setInternalNameRep :: NameRep -> name -> name
setInternalNameRep = OccName -> name -> name
forall name. SetName name => OccName -> name -> name
setInternalOccName (OccName -> name -> name)
-> (NameRep -> OccName) -> NameRep -> name -> name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameRep -> OccName
mkVarOccFS

setInternalOccName :: SetName name => OccName -> name -> name
setInternalOccName :: OccName -> name -> name
setInternalOccName OccName
occ name
name =
    Name -> name -> name
forall name. SetName name => Name -> name -> name
setName Name
nname' name
name
  where
    nname :: Name
nname = name -> Name
forall a. NamedThing a => a -> Name
getName name
name
    nname' :: Name
nname' = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Name -> Unique
nameUnique Name
nname) OccName
occ (Name -> SrcSpan
nameSrcSpan Name
nname)


-- | Compute set of free variables of given type.
freeVariables :: HsType GhcRn -> Set Name
freeVariables :: HsType GhcRn -> Set Name
freeVariables =
    Set Name
-> (Set Name -> Set Name -> Set Name)
-> (forall a. Data a => a -> Set Name -> (Set Name, Set Name))
-> forall a. Data a => a -> Set Name
forall s r.
s
-> (r -> r -> r)
-> (forall a. Data a => a -> s -> (r, s))
-> forall a. Data a => a -> r
everythingWithState Set Name
forall a. Set a
Set.empty Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.union forall a. Data a => a -> Set Name -> (Set Name, Set Name)
forall a. Typeable a => a -> Set Name -> (Set Name, Set Name)
query
  where
    query :: a -> Set Name -> (Set Name, Set Name)
query a
term Set Name
ctx = case a -> Maybe (HsType GhcRn)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
term :: Maybe (HsType GhcRn) of
        Just (HsForAllTy XForAllTy GhcRn
_ ForallVisFlag
_ [LHsTyVarBndr GhcRn]
bndrs LHsType GhcRn
_) ->
            (Set Name
forall a. Set a
Set.empty, Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Name
ctx ([LHsTyVarBndr GhcRn] -> Set Name
bndrsNames [LHsTyVarBndr GhcRn]
bndrs))
        Just (HsTyVar XTyVar GhcRn
_ PromotionFlag
_ (L SrcSpan
_ IdP GhcRn
name))
            | Name -> Name
forall a. NamedThing a => a -> Name
getName IdP GhcRn
Name
name Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
ctx -> (Set Name
forall a. Set a
Set.empty, Set Name
ctx)
            | Bool
otherwise -> (Name -> Set Name
forall a. a -> Set a
Set.singleton (Name -> Set Name) -> Name -> Set Name
forall a b. (a -> b) -> a -> b
$ Name -> Name
forall a. NamedThing a => a -> Name
getName IdP GhcRn
Name
name, Set Name
ctx)
        Maybe (HsType GhcRn)
_ -> (Set Name
forall a. Set a
Set.empty, Set Name
ctx)
    bndrsNames :: [LHsTyVarBndr GhcRn] -> Set Name
bndrsNames = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name)
-> ([LHsTyVarBndr GhcRn] -> [Name])
-> [LHsTyVarBndr GhcRn]
-> Set Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LHsTyVarBndr GhcRn -> Name) -> [LHsTyVarBndr GhcRn] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (IdP GhcRn -> Name
forall a. NamedThing a => a -> Name
getName (IdP GhcRn -> Name)
-> (LHsTyVarBndr GhcRn -> IdP GhcRn) -> LHsTyVarBndr GhcRn -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsTyVarBndr GhcRn -> IdP GhcRn
forall n. (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr n -> IdP n
hsTyVarBndrName (HsTyVarBndr GhcRn -> IdP GhcRn)
-> (LHsTyVarBndr GhcRn -> HsTyVarBndr GhcRn)
-> LHsTyVarBndr GhcRn
-> IdP GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsTyVarBndr GhcRn -> HsTyVarBndr GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc)


-- | Make given type visually unambiguous.
--
-- After applying 'specialize' method, some free type variables may become
-- visually ambiguous - for example, having @a -> b@ and specializing @a@ to
-- @(a -> b)@ we get @(a -> b) -> b@ where first occurrence of @b@ refers to
-- different type variable than latter one. Applying 'rename' function
-- will fix that type to be visually unambiguous again (making it something
-- like @(a -> b0) -> b@).
rename :: Set Name -> HsType GhcRn -> HsType GhcRn
rename :: Set Name -> HsType GhcRn -> HsType GhcRn
rename Set Name
fv HsType GhcRn
typ = State (RenameEnv Name) (HsType GhcRn)
-> RenameEnv Name -> HsType GhcRn
forall s a. State s a -> s -> a
evalState (HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)
renameType HsType GhcRn
typ) RenameEnv Name
forall name. RenameEnv name
env
  where
    env :: RenameEnv name
env = RenameEnv :: forall name.
Map NameRep Name -> Set NameRep -> Map Name name -> RenameEnv name
RenameEnv
      { rneHeadFVs :: Map NameRep Name
rneHeadFVs = [(NameRep, Name)] -> Map NameRep Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(NameRep, Name)] -> Map NameRep Name)
-> (Set Name -> [(NameRep, Name)]) -> Set Name -> Map NameRep Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> (NameRep, Name)) -> [Name] -> [(NameRep, Name)]
forall a b. (a -> b) -> [a] -> [b]
map Name -> (NameRep, Name)
forall b. NamedThing b => b -> (NameRep, b)
mkPair ([Name] -> [(NameRep, Name)])
-> (Set Name -> [Name]) -> Set Name -> [(NameRep, Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Name -> [Name]
forall a. Set a -> [a]
Set.toList (Set Name -> Map NameRep Name) -> Set Name -> Map NameRep Name
forall a b. (a -> b) -> a -> b
$ Set Name
fv
      , rneSigFVs :: Set NameRep
rneSigFVs = (Name -> NameRep) -> Set Name -> Set NameRep
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Name -> NameRep
forall a. NamedThing a => a -> NameRep
getNameRep (Set Name -> Set NameRep) -> Set Name -> Set NameRep
forall a b. (a -> b) -> a -> b
$ HsType GhcRn -> Set Name
freeVariables HsType GhcRn
typ
      , rneCtx :: Map Name name
rneCtx = Map Name name
forall k a. Map k a
Map.empty
      }
    mkPair :: b -> (NameRep, b)
mkPair b
name = (b -> NameRep
forall a. NamedThing a => a -> NameRep
getNameRep b
name, b
name)

-- | Renaming monad.
type Rename name = State (RenameEnv name)

data RenameEnv name = RenameEnv
  { RenameEnv name -> Map NameRep Name
rneHeadFVs :: Map NameRep Name
  , RenameEnv name -> Set NameRep
rneSigFVs :: Set NameRep
  , RenameEnv name -> Map Name name
rneCtx :: Map Name name
  }


renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)
renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)
renameType (HsForAllTy XForAllTy GhcRn
x ForallVisFlag
fvf [LHsTyVarBndr GhcRn]
bndrs LHsType GhcRn
lt) =
    XForAllTy GhcRn
-> ForallVisFlag
-> [LHsTyVarBndr GhcRn]
-> LHsType GhcRn
-> HsType GhcRn
forall pass.
XForAllTy pass
-> ForallVisFlag
-> [LHsTyVarBndr pass]
-> LHsType pass
-> HsType pass
HsForAllTy XForAllTy GhcRn
x ForallVisFlag
fvf
        ([LHsTyVarBndr GhcRn] -> LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity [LHsTyVarBndr GhcRn]
-> StateT (RenameEnv Name) Identity (LHsType GhcRn -> HsType GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LHsTyVarBndr GhcRn
 -> StateT (RenameEnv Name) Identity (LHsTyVarBndr GhcRn))
-> [LHsTyVarBndr GhcRn]
-> StateT (RenameEnv Name) Identity [LHsTyVarBndr GhcRn]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((HsTyVarBndr GhcRn
 -> StateT (RenameEnv Name) Identity (HsTyVarBndr GhcRn))
-> LHsTyVarBndr GhcRn
-> StateT (RenameEnv Name) Identity (LHsTyVarBndr GhcRn)
forall (f :: * -> *) a b.
Functor f =>
(a -> f b) -> Located a -> f (Located b)
located HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn)
HsTyVarBndr GhcRn
-> StateT (RenameEnv Name) Identity (HsTyVarBndr GhcRn)
renameBinder) [LHsTyVarBndr GhcRn]
bndrs
        StateT (RenameEnv Name) Identity (LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
-> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType LHsType GhcRn
lt
renameType (HsQualTy XQualTy GhcRn
x LHsContext GhcRn
lctxt LHsType GhcRn
lt) =
    XQualTy GhcRn -> LHsContext GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy XQualTy GhcRn
x
        (LHsContext GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsContext GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn -> HsType GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([LHsType GhcRn]
 -> StateT (RenameEnv Name) Identity [LHsType GhcRn])
-> LHsContext GhcRn
-> StateT (RenameEnv Name) Identity (LHsContext GhcRn)
forall (f :: * -> *) a b.
Functor f =>
(a -> f b) -> Located a -> f (Located b)
located [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
[LHsType GhcRn] -> StateT (RenameEnv Name) Identity [LHsType GhcRn]
renameContext LHsContext GhcRn
lctxt
        StateT (RenameEnv Name) Identity (LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
-> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType LHsType GhcRn
lt
renameType (HsTyVar XTyVar GhcRn
x PromotionFlag
ip GenLocated SrcSpan (IdP GhcRn)
name) = XTyVar GhcRn
-> PromotionFlag -> GenLocated SrcSpan (IdP GhcRn) -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar XTyVar GhcRn
x PromotionFlag
ip (GenLocated SrcSpan Name -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (GenLocated SrcSpan Name)
-> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> StateT (RenameEnv Name) Identity Name)
-> GenLocated SrcSpan Name
-> StateT (RenameEnv Name) Identity (GenLocated SrcSpan Name)
forall (f :: * -> *) a b.
Functor f =>
(a -> f b) -> Located a -> f (Located b)
located Name -> StateT (RenameEnv Name) Identity Name
forall name. SetName name => name -> Rename name name
renameName GenLocated SrcSpan (IdP GhcRn)
GenLocated SrcSpan Name
name
renameType t :: HsType GhcRn
t@(HsStarTy XStarTy GhcRn
_ Bool
_) = HsType GhcRn -> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsType GhcRn
t
renameType (HsAppTy XAppTy GhcRn
x LHsType GhcRn
lf LHsType GhcRn
la) = XAppTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy XAppTy GhcRn
x (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn -> HsType GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType LHsType GhcRn
lf StateT (RenameEnv Name) Identity (LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
-> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType LHsType GhcRn
la
renameType (HsAppKindTy XAppKindTy GhcRn
x LHsType GhcRn
lt LHsType GhcRn
lk) = XAppKindTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XAppKindTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppKindTy XAppKindTy GhcRn
x (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn -> HsType GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType LHsType GhcRn
lt StateT (RenameEnv Name) Identity (LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
-> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLKind LHsType GhcRn
lk
renameType (HsFunTy XFunTy GhcRn
x LHsType GhcRn
la LHsType GhcRn
lr) = XFunTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcRn
x (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn -> HsType GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType LHsType GhcRn
la StateT (RenameEnv Name) Identity (LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
-> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType LHsType GhcRn
lr
renameType (HsListTy XListTy GhcRn
x LHsType GhcRn
lt) = XListTy GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy XListTy GhcRn
x (LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
-> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType LHsType GhcRn
lt
renameType (HsTupleTy XTupleTy GhcRn
x HsTupleSort
srt [LHsType GhcRn]
lt) = XTupleTy GhcRn -> HsTupleSort -> [LHsType GhcRn] -> HsType GhcRn
forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy XTupleTy GhcRn
x HsTupleSort
srt ([LHsType GhcRn] -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity [LHsType GhcRn]
-> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LHsType GhcRn -> StateT (RenameEnv Name) Identity (LHsType GhcRn))
-> [LHsType GhcRn]
-> StateT (RenameEnv Name) Identity [LHsType GhcRn]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
LHsType GhcRn -> StateT (RenameEnv Name) Identity (LHsType GhcRn)
renameLType [LHsType GhcRn]
lt
renameType (HsSumTy XSumTy GhcRn
x [LHsType GhcRn]
lt) = XSumTy GhcRn -> [LHsType GhcRn] -> HsType GhcRn
forall pass. XSumTy pass -> [LHsType pass] -> HsType pass
HsSumTy XSumTy GhcRn
x ([LHsType GhcRn] -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity [LHsType GhcRn]
-> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LHsType GhcRn -> StateT (RenameEnv Name) Identity (LHsType GhcRn))
-> [LHsType GhcRn]
-> StateT (RenameEnv Name) Identity [LHsType GhcRn]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
LHsType GhcRn -> StateT (RenameEnv Name) Identity (LHsType GhcRn)
renameLType [LHsType GhcRn]
lt
renameType (HsOpTy XOpTy GhcRn
x LHsType GhcRn
la GenLocated SrcSpan (IdP GhcRn)
lop LHsType GhcRn
lb) =
    XOpTy GhcRn
-> LHsType GhcRn
-> GenLocated SrcSpan (IdP GhcRn)
-> LHsType GhcRn
-> HsType GhcRn
forall pass.
XOpTy pass
-> LHsType pass
-> Located (IdP pass)
-> LHsType pass
-> HsType pass
HsOpTy XOpTy GhcRn
x (LHsType GhcRn
 -> GenLocated SrcSpan Name -> LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
-> StateT
     (RenameEnv Name)
     Identity
     (GenLocated SrcSpan Name -> LHsType GhcRn -> HsType GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType LHsType GhcRn
la StateT
  (RenameEnv Name)
  Identity
  (GenLocated SrcSpan Name -> LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (GenLocated SrcSpan Name)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn -> HsType GhcRn)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Name -> StateT (RenameEnv Name) Identity Name)
-> GenLocated SrcSpan Name
-> StateT (RenameEnv Name) Identity (GenLocated SrcSpan Name)
forall (f :: * -> *) a b.
Functor f =>
(a -> f b) -> Located a -> f (Located b)
located Name -> StateT (RenameEnv Name) Identity Name
forall name. SetName name => name -> Rename name name
renameName GenLocated SrcSpan (IdP GhcRn)
GenLocated SrcSpan Name
lop StateT (RenameEnv Name) Identity (LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
-> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType LHsType GhcRn
lb
renameType (HsParTy XParTy GhcRn
x LHsType GhcRn
lt) = XParTy GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcRn
x (LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
-> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType LHsType GhcRn
lt
renameType (HsIParamTy XIParamTy GhcRn
x Located HsIPName
ip LHsType GhcRn
lt) = XIParamTy GhcRn
-> Located HsIPName -> LHsType GhcRn -> HsType GhcRn
forall pass.
XIParamTy pass -> Located HsIPName -> LHsType pass -> HsType pass
HsIParamTy XIParamTy GhcRn
x Located HsIPName
ip (LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
-> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType LHsType GhcRn
lt
renameType (HsKindSig XKindSig GhcRn
x LHsType GhcRn
lt LHsType GhcRn
lk) = XKindSig GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XKindSig pass -> LHsType pass -> LHsType pass -> HsType pass
HsKindSig XKindSig GhcRn
x (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn -> HsType GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType LHsType GhcRn
lt StateT (RenameEnv Name) Identity (LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
-> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsType GhcRn -> StateT (RenameEnv Name) Identity (LHsType GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcRn
lk
renameType t :: HsType GhcRn
t@(HsSpliceTy XSpliceTy GhcRn
_ HsSplice GhcRn
_) = HsType GhcRn -> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsType GhcRn
t
renameType (HsDocTy XDocTy GhcRn
x LHsType GhcRn
lt LHsDocString
doc) = XDocTy GhcRn -> LHsType GhcRn -> LHsDocString -> HsType GhcRn
forall pass.
XDocTy pass -> LHsType pass -> LHsDocString -> HsType pass
HsDocTy XDocTy GhcRn
x (LHsType GhcRn -> LHsDocString -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsDocString -> HsType GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType LHsType GhcRn
lt StateT (RenameEnv Name) Identity (LHsDocString -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity LHsDocString
-> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsDocString -> StateT (RenameEnv Name) Identity LHsDocString
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsDocString
doc
renameType (HsBangTy XBangTy GhcRn
x HsSrcBang
bang LHsType GhcRn
lt) = XBangTy GhcRn -> HsSrcBang -> LHsType GhcRn -> HsType GhcRn
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy GhcRn
x HsSrcBang
bang (LHsType GhcRn -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
-> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType LHsType GhcRn
lt
renameType t :: HsType GhcRn
t@(HsRecTy XRecTy GhcRn
_ [LConDeclField GhcRn]
_) = HsType GhcRn -> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsType GhcRn
t
renameType t :: HsType GhcRn
t@(XHsType (NHsCoreTy _)) = HsType GhcRn -> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsType GhcRn
t
renameType (HsExplicitListTy XExplicitListTy GhcRn
x PromotionFlag
ip [LHsType GhcRn]
ltys) =
    XExplicitListTy GhcRn
-> PromotionFlag -> [LHsType GhcRn] -> HsType GhcRn
forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy XExplicitListTy GhcRn
x PromotionFlag
ip ([LHsType GhcRn] -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity [LHsType GhcRn]
-> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
renameLTypes [LHsType GhcRn]
ltys
renameType (HsExplicitTupleTy XExplicitTupleTy GhcRn
x [LHsType GhcRn]
ltys) =
    XExplicitTupleTy GhcRn -> [LHsType GhcRn] -> HsType GhcRn
forall pass. XExplicitTupleTy pass -> [LHsType pass] -> HsType pass
HsExplicitTupleTy XExplicitTupleTy GhcRn
x ([LHsType GhcRn] -> HsType GhcRn)
-> StateT (RenameEnv Name) Identity [LHsType GhcRn]
-> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
renameLTypes [LHsType GhcRn]
ltys
renameType t :: HsType GhcRn
t@(HsTyLit XTyLit GhcRn
_ HsTyLit
_) = HsType GhcRn -> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsType GhcRn
t
renameType (HsWildCardTy XWildCardTy GhcRn
wc) = HsType GhcRn -> State (RenameEnv Name) (HsType GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XWildCardTy GhcRn -> HsType GhcRn
forall pass. XWildCardTy pass -> HsType pass
HsWildCardTy XWildCardTy GhcRn
wc)


renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType = (HsType GhcRn -> State (RenameEnv Name) (HsType GhcRn))
-> LHsType GhcRn
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
forall (f :: * -> *) a b.
Functor f =>
(a -> f b) -> Located a -> f (Located b)
located HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)
HsType GhcRn -> State (RenameEnv Name) (HsType GhcRn)
renameType

renameLKind :: LHsKind GhcRn -> Rename (IdP GhcRn) (LHsKind GhcRn)
renameLKind :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLKind = LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType

renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
renameLTypes = (LHsType GhcRn -> StateT (RenameEnv Name) Identity (LHsType GhcRn))
-> [LHsType GhcRn]
-> StateT (RenameEnv Name) Identity [LHsType GhcRn]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
LHsType GhcRn -> StateT (RenameEnv Name) Identity (LHsType GhcRn)
renameLType


renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn)
renameContext :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
renameContext = [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
renameLTypes

renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn)
renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn)
renameBinder (UserTyVar XUserTyVar GhcRn
x GenLocated SrcSpan (IdP GhcRn)
lname) = XUserTyVar GhcRn
-> GenLocated SrcSpan (IdP GhcRn) -> HsTyVarBndr GhcRn
forall pass.
XUserTyVar pass -> Located (IdP pass) -> HsTyVarBndr pass
UserTyVar XUserTyVar GhcRn
x (GenLocated SrcSpan Name -> HsTyVarBndr GhcRn)
-> StateT (RenameEnv Name) Identity (GenLocated SrcSpan Name)
-> StateT (RenameEnv Name) Identity (HsTyVarBndr GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> StateT (RenameEnv Name) Identity Name)
-> GenLocated SrcSpan Name
-> StateT (RenameEnv Name) Identity (GenLocated SrcSpan Name)
forall (f :: * -> *) a b.
Functor f =>
(a -> f b) -> Located a -> f (Located b)
located Name -> StateT (RenameEnv Name) Identity Name
forall name. SetName name => name -> Rename name name
renameName GenLocated SrcSpan (IdP GhcRn)
GenLocated SrcSpan Name
lname
renameBinder (KindedTyVar XKindedTyVar GhcRn
x GenLocated SrcSpan (IdP GhcRn)
lname LHsType GhcRn
lkind) =
  XKindedTyVar GhcRn
-> GenLocated SrcSpan (IdP GhcRn)
-> LHsType GhcRn
-> HsTyVarBndr GhcRn
forall pass.
XKindedTyVar pass
-> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr pass
KindedTyVar XKindedTyVar GhcRn
x (GenLocated SrcSpan Name -> LHsType GhcRn -> HsTyVarBndr GhcRn)
-> StateT (RenameEnv Name) Identity (GenLocated SrcSpan Name)
-> StateT
     (RenameEnv Name) Identity (LHsType GhcRn -> HsTyVarBndr GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> StateT (RenameEnv Name) Identity Name)
-> GenLocated SrcSpan Name
-> StateT (RenameEnv Name) Identity (GenLocated SrcSpan Name)
forall (f :: * -> *) a b.
Functor f =>
(a -> f b) -> Located a -> f (Located b)
located Name -> StateT (RenameEnv Name) Identity Name
forall name. SetName name => name -> Rename name name
renameName GenLocated SrcSpan (IdP GhcRn)
GenLocated SrcSpan Name
lname StateT
  (RenameEnv Name) Identity (LHsType GhcRn -> HsTyVarBndr GhcRn)
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
-> StateT (RenameEnv Name) Identity (HsTyVarBndr GhcRn)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (HsType GhcRn -> State (RenameEnv Name) (HsType GhcRn))
-> LHsType GhcRn
-> StateT (RenameEnv Name) Identity (LHsType GhcRn)
forall (f :: * -> *) a b.
Functor f =>
(a -> f b) -> Located a -> f (Located b)
located HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)
HsType GhcRn -> State (RenameEnv Name) (HsType GhcRn)
renameType LHsType GhcRn
lkind
renameBinder (XTyVarBndr XXTyVarBndr GhcRn
nec) = NoExtCon -> StateT (RenameEnv Name) Identity (HsTyVarBndr GhcRn)
forall a. NoExtCon -> a
noExtCon NoExtCon
XXTyVarBndr GhcRn
nec

-- | Core renaming logic.
renameName :: SetName name => name -> Rename name name
renameName :: name -> Rename name name
renameName name
name = do
    RenameEnv { Map NameRep Name
Map Name name
Set NameRep
rneCtx :: Map Name name
rneSigFVs :: Set NameRep
rneHeadFVs :: Map NameRep Name
rneCtx :: forall name. RenameEnv name -> Map Name name
rneSigFVs :: forall name. RenameEnv name -> Set NameRep
rneHeadFVs :: forall name. RenameEnv name -> Map NameRep Name
.. } <- StateT (RenameEnv name) Identity (RenameEnv name)
forall (m :: * -> *) s. Monad m => StateT s m s
get
    case Name -> Map Name name -> Maybe name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (name -> Name
forall a. NamedThing a => a -> Name
getName name
name) Map Name name
rneCtx of
      Maybe name
Nothing
        | Just Name
headTv <- NameRep -> Map NameRep Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (name -> NameRep
forall a. NamedThing a => a -> NameRep
getNameRep name
name) Map NameRep Name
rneHeadFVs
        , Name
headTv Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= name -> Name
forall a. NamedThing a => a -> Name
getName name
name -> name -> Rename name name
forall name. SetName name => name -> Rename name name
freshName name
name
      Just name
name' -> name -> Rename name name
forall (m :: * -> *) a. Monad m => a -> m a
return name
name'
      Maybe name
_ -> name -> Rename name name
forall (m :: * -> *) a. Monad m => a -> m a
return name
name


-- | Generate fresh occurrence name, put it into context and return.
freshName :: SetName name => name -> Rename name name
freshName :: name -> Rename name name
freshName name
name = do
    Set NameRep
taken <- Rename name (Set NameRep)
forall name. NamedThing name => Rename name (Set NameRep)
takenNames
    let name' :: name
name' = NameRep -> name -> name
forall name. SetName name => NameRep -> name -> name
setInternalNameRep (Set NameRep -> NameRep -> NameRep
findFreshName Set NameRep
taken NameRep
rep) name
name
    (RenameEnv name -> RenameEnv name)
-> StateT (RenameEnv name) Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((RenameEnv name -> RenameEnv name)
 -> StateT (RenameEnv name) Identity ())
-> (RenameEnv name -> RenameEnv name)
-> StateT (RenameEnv name) Identity ()
forall a b. (a -> b) -> a -> b
$ \RenameEnv name
rne -> RenameEnv name
rne
      { rneCtx :: Map Name name
rneCtx = Name -> name -> Map Name name -> Map Name name
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (name -> Name
forall a. NamedThing a => a -> Name
getName name
name) name
name' (RenameEnv name -> Map Name name
forall name. RenameEnv name -> Map Name name
rneCtx RenameEnv name
rne) }
    name -> Rename name name
forall (m :: * -> *) a. Monad m => a -> m a
return name
name'
  where
    nname :: Name
nname = name -> Name
forall a. NamedThing a => a -> Name
getName name
name
    rep :: NameRep
rep = Name -> NameRep
forall a. NamedThing a => a -> NameRep
getNameRep Name
nname


takenNames :: NamedThing name => Rename name (Set NameRep)
takenNames :: Rename name (Set NameRep)
takenNames = do
    RenameEnv { Map NameRep Name
Map Name name
Set NameRep
rneCtx :: Map Name name
rneSigFVs :: Set NameRep
rneHeadFVs :: Map NameRep Name
rneCtx :: forall name. RenameEnv name -> Map Name name
rneSigFVs :: forall name. RenameEnv name -> Set NameRep
rneHeadFVs :: forall name. RenameEnv name -> Map NameRep Name
.. } <- StateT (RenameEnv name) Identity (RenameEnv name)
forall (m :: * -> *) s. Monad m => StateT s m s
get
    Set NameRep -> Rename name (Set NameRep)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set NameRep -> Rename name (Set NameRep))
-> Set NameRep -> Rename name (Set NameRep)
forall a b. (a -> b) -> a -> b
$ [Set NameRep] -> Set NameRep
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Map NameRep Name -> Set NameRep
forall a. Map NameRep a -> Set NameRep
headReps Map NameRep Name
rneHeadFVs, Set NameRep
rneSigFVs, Map Name name -> Set NameRep
forall k. Map k name -> Set NameRep
ctxElems Map Name name
rneCtx]
  where
    headReps :: Map NameRep a -> Set NameRep
headReps = [NameRep] -> Set NameRep
forall a. Ord a => [a] -> Set a
Set.fromList ([NameRep] -> Set NameRep)
-> (Map NameRep a -> [NameRep]) -> Map NameRep a -> Set NameRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map NameRep a -> [NameRep]
forall k a. Map k a -> [k]
Map.keys
    ctxElems :: Map k name -> Set NameRep
ctxElems = [NameRep] -> Set NameRep
forall a. Ord a => [a] -> Set a
Set.fromList ([NameRep] -> Set NameRep)
-> (Map k name -> [NameRep]) -> Map k name -> Set NameRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (name -> NameRep) -> [name] -> [NameRep]
forall a b. (a -> b) -> [a] -> [b]
map name -> NameRep
forall a. NamedThing a => a -> NameRep
getNameRep ([name] -> [NameRep])
-> (Map k name -> [name]) -> Map k name -> [NameRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k name -> [name]
forall k a. Map k a -> [a]
Map.elems


findFreshName :: Set NameRep -> NameRep -> NameRep
findFreshName :: Set NameRep -> NameRep -> NameRep
findFreshName Set NameRep
taken =
    Maybe NameRep -> NameRep
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe NameRep -> NameRep)
-> (NameRep -> Maybe NameRep) -> NameRep -> NameRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NameRep -> Bool) -> [NameRep] -> Maybe NameRep
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find NameRep -> Bool
isFresh ([NameRep] -> Maybe NameRep)
-> (NameRep -> [NameRep]) -> NameRep -> Maybe NameRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameRep -> [NameRep]
alternativeNames
  where
    isFresh :: NameRep -> Bool
isFresh = Bool -> Bool
not (Bool -> Bool) -> (NameRep -> Bool) -> NameRep -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NameRep -> Set NameRep -> Bool) -> Set NameRep -> NameRep -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip NameRep -> Set NameRep -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Set NameRep
taken


alternativeNames :: NameRep -> [NameRep]
alternativeNames :: NameRep -> [NameRep]
alternativeNames NameRep
name =
    [ String -> NameRep
stringNameRep (String -> NameRep) -> String -> NameRep
forall a b. (a -> b) -> a -> b
$ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i | Int
i :: Int <- [Int
0..] ]
  where
    str :: String
str = NameRep -> String
nameRepString NameRep
name


located :: Functor f => (a -> f b) -> Located a -> f (Located b)
located :: (a -> f b) -> Located a -> f (Located b)
located a -> f b
f (L SrcSpan
loc a
e) = SrcSpan -> b -> Located b
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (b -> Located b) -> f b -> f (Located b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
e