uhc-light-1.1.9.1: src/UHC/Light/Compiler/Ty/UsedNames.hs
-- UUAGC 0.9.52.1 (build/103/lib-ehc/UHC/Light/Compiler/Ty/UsedNames.a)
module UHC.Light.Compiler.Ty.UsedNames(tyUsedNames) where
import Data.List
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Ty
import qualified Data.Set as Set
import qualified Data.Map as Map
import UHC.Light.Compiler.Module.ImportExport
{-|
There are some conventions/restrictions on the structure of types that are not enforced
by the abstract syntax:
Encoding of prove-constraints:
concrete syntax:
{! impls !} -> ty
abstract syntax:
Ty_App (Ty_App (Ty_Con "->") (Ty_Impls impls)) ty
Encoding of assume-constraints:
concrete syntax:
(ty, {! pred1 !}, ..., {! predn !})
abstract syntax:
Ty_Ext (... (Ty_Ext ty (prod m+1) (Ty_Pred pred_1) ) ...) (prod m+n) (Ty_Pred pred_n)
In other words: the predicates are at the outset of a product, pred_n "more outermost"
than pred_{n-1}.
-}
{-|
The basic alternatives encode the following:
- Con: data type constructors, including tuple constructors
- App: application to 1 argument, for example 'a -> b' is encoded as (App (App -> a) b)
- Any: representing Bot/Top depending on context: (1) unknown expected type, (2) error type
- Var: type variables, including a category: plain tyvars, fixed tyvars (aka skolems)
-}
tyUsedNames :: HsName -> Ty -> ModEntRelFilterMp
tyUsedNames moduleNm ty
= mentrelFilterMp_Syn_TyAGItf t
where t = wrap_TyAGItf
(sem_TyAGItf (TyAGItf_AGItf ty))
(Inh_TyAGItf
{ moduleNm_Inh_TyAGItf = moduleNm
})
-- Impls -------------------------------------------------------
{-
visit 0:
inherited attribute:
moduleNm : HsName
synthesized attribute:
mentrelFilterMp : ModEntRelFilterMp
alternatives:
alternative Tail:
child iv : {ImplsVarId}
child proveOccs : {[ImplsProveOcc]}
alternative Cons:
child iv : {ImplsVarId}
child pr : Pred
child pv : {PredOccId}
child prange : {Range}
child proveOccs : {[ImplsProveOcc]}
child tl : Impls
alternative Nil:
-}
-- cata
sem_Impls :: Impls ->
T_Impls
sem_Impls (Impls_Tail _iv _proveOccs) =
(sem_Impls_Tail _iv _proveOccs)
sem_Impls (Impls_Cons _iv _pr _pv _prange _proveOccs _tl) =
(sem_Impls_Cons _iv (sem_Pred _pr) _pv _prange _proveOccs (sem_Impls _tl))
sem_Impls (Impls_Nil) =
(sem_Impls_Nil)
-- semantic domain
type T_Impls = HsName ->
( ModEntRelFilterMp)
sem_Impls_Tail :: ImplsVarId ->
([ImplsProveOcc]) ->
T_Impls
sem_Impls_Tail iv_ proveOccs_ =
(\ _lhsImoduleNm ->
(case (Map.empty) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }))
sem_Impls_Cons :: ImplsVarId ->
T_Pred ->
PredOccId ->
Range ->
([ImplsProveOcc]) ->
T_Impls ->
T_Impls
sem_Impls_Cons iv_ pr_ pv_ prange_ proveOccs_ tl_ =
(\ _lhsImoduleNm ->
(case (_lhsImoduleNm) of
{ _tlOmoduleNm ->
(case (_lhsImoduleNm) of
{ _prOmoduleNm ->
(case (tl_ _tlOmoduleNm) of
{ ( _tlImentrelFilterMp) ->
(case (pr_ _prOmoduleNm) of
{ ( _prImentrelFilterMp) ->
(case (_prImentrelFilterMp `mentrelFilterMpUnion` _tlImentrelFilterMp) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }) }) }) }) }))
sem_Impls_Nil :: T_Impls
sem_Impls_Nil =
(\ _lhsImoduleNm ->
(case (Map.empty) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }))
-- Label -------------------------------------------------------
{-
alternatives:
alternative Lab:
child nm : {HsName}
alternative Var:
child lv : {LabelVarId}
-}
-- cata
sem_Label :: Label ->
T_Label
sem_Label (Label_Lab _nm) =
(sem_Label_Lab _nm)
sem_Label (Label_Var _lv) =
(sem_Label_Var _lv)
-- semantic domain
type T_Label = ( )
sem_Label_Lab :: HsName ->
T_Label
sem_Label_Lab nm_ =
( )
sem_Label_Var :: LabelVarId ->
T_Label
sem_Label_Var lv_ =
( )
-- LabelAGItf --------------------------------------------------
{-
alternatives:
alternative AGItf:
child lab : Label
-}
-- cata
sem_LabelAGItf :: LabelAGItf ->
T_LabelAGItf
sem_LabelAGItf (LabelAGItf_AGItf _lab) =
(sem_LabelAGItf_AGItf (sem_Label _lab))
-- semantic domain
type T_LabelAGItf = ( )
sem_LabelAGItf_AGItf :: T_Label ->
T_LabelAGItf
sem_LabelAGItf_AGItf lab_ =
( )
-- Pred --------------------------------------------------------
{-
visit 0:
inherited attribute:
moduleNm : HsName
synthesized attribute:
mentrelFilterMp : ModEntRelFilterMp
alternatives:
alternative Class:
child ty : Ty
alternative Pred:
child ty : Ty
alternative Lacks:
child ty : Ty
child lab : Label
alternative Arrow:
child args : PredSeq
child res : Pred
alternative Eq:
child tyL : Ty
child tyR : Ty
alternative Var:
child pv : {TyVarId}
alternative Preds:
child seq : PredSeq
-}
-- cata
sem_Pred :: Pred ->
T_Pred
sem_Pred (Pred_Class _ty) =
(sem_Pred_Class (sem_Ty _ty))
sem_Pred (Pred_Pred _ty) =
(sem_Pred_Pred (sem_Ty _ty))
sem_Pred (Pred_Lacks _ty _lab) =
(sem_Pred_Lacks (sem_Ty _ty) (sem_Label _lab))
sem_Pred (Pred_Arrow _args _res) =
(sem_Pred_Arrow (sem_PredSeq _args) (sem_Pred _res))
sem_Pred (Pred_Eq _tyL _tyR) =
(sem_Pred_Eq (sem_Ty _tyL) (sem_Ty _tyR))
sem_Pred (Pred_Var _pv) =
(sem_Pred_Var _pv)
sem_Pred (Pred_Preds _seq) =
(sem_Pred_Preds (sem_PredSeq _seq))
-- semantic domain
type T_Pred = HsName ->
( ModEntRelFilterMp)
sem_Pred_Class :: T_Ty ->
T_Pred
sem_Pred_Class ty_ =
(\ _lhsImoduleNm ->
(case (_lhsImoduleNm) of
{ _tyOmoduleNm ->
(case (ty_ _tyOmoduleNm) of
{ ( _tyImentrelFilterMp) ->
(case (_tyImentrelFilterMp) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }) }) }))
sem_Pred_Pred :: T_Ty ->
T_Pred
sem_Pred_Pred ty_ =
(\ _lhsImoduleNm ->
(case (_lhsImoduleNm) of
{ _tyOmoduleNm ->
(case (ty_ _tyOmoduleNm) of
{ ( _tyImentrelFilterMp) ->
(case (_tyImentrelFilterMp) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }) }) }))
sem_Pred_Lacks :: T_Ty ->
T_Label ->
T_Pred
sem_Pred_Lacks ty_ lab_ =
(\ _lhsImoduleNm ->
(case (_lhsImoduleNm) of
{ _tyOmoduleNm ->
(case (ty_ _tyOmoduleNm) of
{ ( _tyImentrelFilterMp) ->
(case (_tyImentrelFilterMp) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }) }) }))
sem_Pred_Arrow :: T_PredSeq ->
T_Pred ->
T_Pred
sem_Pred_Arrow args_ res_ =
(\ _lhsImoduleNm ->
(case (_lhsImoduleNm) of
{ _resOmoduleNm ->
(case (_lhsImoduleNm) of
{ _argsOmoduleNm ->
(case (res_ _resOmoduleNm) of
{ ( _resImentrelFilterMp) ->
(case (args_ _argsOmoduleNm) of
{ ( _argsImentrelFilterMp) ->
(case (_argsImentrelFilterMp `mentrelFilterMpUnion` _resImentrelFilterMp) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }) }) }) }) }))
sem_Pred_Eq :: T_Ty ->
T_Ty ->
T_Pred
sem_Pred_Eq tyL_ tyR_ =
(\ _lhsImoduleNm ->
(case (_lhsImoduleNm) of
{ _tyROmoduleNm ->
(case (_lhsImoduleNm) of
{ _tyLOmoduleNm ->
(case (tyR_ _tyROmoduleNm) of
{ ( _tyRImentrelFilterMp) ->
(case (tyL_ _tyLOmoduleNm) of
{ ( _tyLImentrelFilterMp) ->
(case (_tyLImentrelFilterMp `mentrelFilterMpUnion` _tyRImentrelFilterMp) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }) }) }) }) }))
sem_Pred_Var :: TyVarId ->
T_Pred
sem_Pred_Var pv_ =
(\ _lhsImoduleNm ->
(case (Map.empty) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }))
sem_Pred_Preds :: T_PredSeq ->
T_Pred
sem_Pred_Preds seq_ =
(\ _lhsImoduleNm ->
(case (_lhsImoduleNm) of
{ _seqOmoduleNm ->
(case (seq_ _seqOmoduleNm) of
{ ( _seqImentrelFilterMp) ->
(case (_seqImentrelFilterMp) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }) }) }))
-- PredSeq -----------------------------------------------------
{-
visit 0:
inherited attribute:
moduleNm : HsName
synthesized attribute:
mentrelFilterMp : ModEntRelFilterMp
alternatives:
alternative Cons:
child hd : Pred
child tl : PredSeq
alternative Nil:
alternative Var:
child av : {TyVarId}
-}
-- cata
sem_PredSeq :: PredSeq ->
T_PredSeq
sem_PredSeq (PredSeq_Cons _hd _tl) =
(sem_PredSeq_Cons (sem_Pred _hd) (sem_PredSeq _tl))
sem_PredSeq (PredSeq_Nil) =
(sem_PredSeq_Nil)
sem_PredSeq (PredSeq_Var _av) =
(sem_PredSeq_Var _av)
-- semantic domain
type T_PredSeq = HsName ->
( ModEntRelFilterMp)
sem_PredSeq_Cons :: T_Pred ->
T_PredSeq ->
T_PredSeq
sem_PredSeq_Cons hd_ tl_ =
(\ _lhsImoduleNm ->
(case (_lhsImoduleNm) of
{ _tlOmoduleNm ->
(case (_lhsImoduleNm) of
{ _hdOmoduleNm ->
(case (tl_ _tlOmoduleNm) of
{ ( _tlImentrelFilterMp) ->
(case (hd_ _hdOmoduleNm) of
{ ( _hdImentrelFilterMp) ->
(case (_hdImentrelFilterMp `mentrelFilterMpUnion` _tlImentrelFilterMp) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }) }) }) }) }))
sem_PredSeq_Nil :: T_PredSeq
sem_PredSeq_Nil =
(\ _lhsImoduleNm ->
(case (Map.empty) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }))
sem_PredSeq_Var :: TyVarId ->
T_PredSeq
sem_PredSeq_Var av_ =
(\ _lhsImoduleNm ->
(case (Map.empty) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }))
-- Ty ----------------------------------------------------------
{-
visit 0:
inherited attribute:
moduleNm : HsName
synthesized attribute:
mentrelFilterMp : ModEntRelFilterMp
alternatives:
alternative Con:
child nm : {HsName}
alternative App:
child func : Ty
child arg : Ty
alternative Ann:
child ann : TyAnn
child ty : Ty
alternative Dbg:
child info : {String}
alternative Any:
alternative Var:
child tv : {TyVarId}
child categ : TyVarCateg
alternative TBind:
child qu : TyQu
child tv : {TyVarId}
child l1 : {Ty}
child ty : Ty
alternative Ext:
child ty : Ty
child nm : {HsName}
child extTy : Ty
alternative Pred:
child pr : Pred
alternative Lam:
child tv : {TyVarId}
child ty : Ty
alternative Impls:
child impls : Impls
-}
-- cata
sem_Ty :: Ty ->
T_Ty
sem_Ty (Ty_Con _nm) =
(sem_Ty_Con _nm)
sem_Ty (Ty_App _func _arg) =
(sem_Ty_App (sem_Ty _func) (sem_Ty _arg))
sem_Ty (Ty_Ann _ann _ty) =
(sem_Ty_Ann (sem_TyAnn _ann) (sem_Ty _ty))
sem_Ty (Ty_Dbg _info) =
(sem_Ty_Dbg _info)
sem_Ty (Ty_Any) =
(sem_Ty_Any)
sem_Ty (Ty_Var _tv _categ) =
(sem_Ty_Var _tv (sem_TyVarCateg _categ))
sem_Ty (Ty_TBind _qu _tv _l1 _ty) =
(sem_Ty_TBind (sem_TyQu _qu) _tv _l1 (sem_Ty _ty))
sem_Ty (Ty_Ext _ty _nm _extTy) =
(sem_Ty_Ext (sem_Ty _ty) _nm (sem_Ty _extTy))
sem_Ty (Ty_Pred _pr) =
(sem_Ty_Pred (sem_Pred _pr))
sem_Ty (Ty_Lam _tv _ty) =
(sem_Ty_Lam _tv (sem_Ty _ty))
sem_Ty (Ty_Impls _impls) =
(sem_Ty_Impls (sem_Impls _impls))
-- semantic domain
type T_Ty = HsName ->
( ModEntRelFilterMp)
sem_Ty_Con :: HsName ->
T_Ty
sem_Ty_Con nm_ =
(\ _lhsImoduleNm ->
(case (mentrelFilterMpSingleton [_lhsImoduleNm] IdOcc_Type nm_) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }))
sem_Ty_App :: T_Ty ->
T_Ty ->
T_Ty
sem_Ty_App func_ arg_ =
(\ _lhsImoduleNm ->
(case (_lhsImoduleNm) of
{ _argOmoduleNm ->
(case (_lhsImoduleNm) of
{ _funcOmoduleNm ->
(case (arg_ _argOmoduleNm) of
{ ( _argImentrelFilterMp) ->
(case (func_ _funcOmoduleNm) of
{ ( _funcImentrelFilterMp) ->
(case (_funcImentrelFilterMp `mentrelFilterMpUnion` _argImentrelFilterMp) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }) }) }) }) }))
sem_Ty_Ann :: T_TyAnn ->
T_Ty ->
T_Ty
sem_Ty_Ann ann_ ty_ =
(\ _lhsImoduleNm ->
(case (_lhsImoduleNm) of
{ _tyOmoduleNm ->
(case (ty_ _tyOmoduleNm) of
{ ( _tyImentrelFilterMp) ->
(case (_tyImentrelFilterMp) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }) }) }))
sem_Ty_Dbg :: String ->
T_Ty
sem_Ty_Dbg info_ =
(\ _lhsImoduleNm ->
(case (Map.empty) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }))
sem_Ty_Any :: T_Ty
sem_Ty_Any =
(\ _lhsImoduleNm ->
(case (Map.empty) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }))
sem_Ty_Var :: TyVarId ->
T_TyVarCateg ->
T_Ty
sem_Ty_Var tv_ categ_ =
(\ _lhsImoduleNm ->
(case (Map.empty) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }))
sem_Ty_TBind :: T_TyQu ->
TyVarId ->
Ty ->
T_Ty ->
T_Ty
sem_Ty_TBind qu_ tv_ l1_ ty_ =
(\ _lhsImoduleNm ->
(case (_lhsImoduleNm) of
{ _tyOmoduleNm ->
(case (ty_ _tyOmoduleNm) of
{ ( _tyImentrelFilterMp) ->
(case (_tyImentrelFilterMp) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }) }) }))
sem_Ty_Ext :: T_Ty ->
HsName ->
T_Ty ->
T_Ty
sem_Ty_Ext ty_ nm_ extTy_ =
(\ _lhsImoduleNm ->
(case (_lhsImoduleNm) of
{ _extTyOmoduleNm ->
(case (_lhsImoduleNm) of
{ _tyOmoduleNm ->
(case (extTy_ _extTyOmoduleNm) of
{ ( _extTyImentrelFilterMp) ->
(case (ty_ _tyOmoduleNm) of
{ ( _tyImentrelFilterMp) ->
(case (_tyImentrelFilterMp `mentrelFilterMpUnion` _extTyImentrelFilterMp) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }) }) }) }) }))
sem_Ty_Pred :: T_Pred ->
T_Ty
sem_Ty_Pred pr_ =
(\ _lhsImoduleNm ->
(case (_lhsImoduleNm) of
{ _prOmoduleNm ->
(case (pr_ _prOmoduleNm) of
{ ( _prImentrelFilterMp) ->
(case (_prImentrelFilterMp) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }) }) }))
sem_Ty_Lam :: TyVarId ->
T_Ty ->
T_Ty
sem_Ty_Lam tv_ ty_ =
(\ _lhsImoduleNm ->
(case (_lhsImoduleNm) of
{ _tyOmoduleNm ->
(case (ty_ _tyOmoduleNm) of
{ ( _tyImentrelFilterMp) ->
(case (_tyImentrelFilterMp) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }) }) }))
sem_Ty_Impls :: T_Impls ->
T_Ty
sem_Ty_Impls impls_ =
(\ _lhsImoduleNm ->
(case (_lhsImoduleNm) of
{ _implsOmoduleNm ->
(case (impls_ _implsOmoduleNm) of
{ ( _implsImentrelFilterMp) ->
(case (_implsImentrelFilterMp) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }) }) }))
-- TyAGItf -----------------------------------------------------
{-
visit 0:
inherited attribute:
moduleNm : HsName
synthesized attribute:
mentrelFilterMp : ModEntRelFilterMp
alternatives:
alternative AGItf:
child ty : Ty
-}
-- cata
sem_TyAGItf :: TyAGItf ->
T_TyAGItf
sem_TyAGItf (TyAGItf_AGItf _ty) =
(sem_TyAGItf_AGItf (sem_Ty _ty))
-- semantic domain
type T_TyAGItf = HsName ->
( ModEntRelFilterMp)
data Inh_TyAGItf = Inh_TyAGItf {moduleNm_Inh_TyAGItf :: !(HsName)}
data Syn_TyAGItf = Syn_TyAGItf {mentrelFilterMp_Syn_TyAGItf :: !(ModEntRelFilterMp)}
wrap_TyAGItf :: T_TyAGItf ->
Inh_TyAGItf ->
Syn_TyAGItf
wrap_TyAGItf sem (Inh_TyAGItf _lhsImoduleNm) =
(let ( _lhsOmentrelFilterMp) = sem _lhsImoduleNm
in (Syn_TyAGItf _lhsOmentrelFilterMp))
sem_TyAGItf_AGItf :: T_Ty ->
T_TyAGItf
sem_TyAGItf_AGItf ty_ =
(\ _lhsImoduleNm ->
(case (_lhsImoduleNm) of
{ _tyOmoduleNm ->
(case (ty_ _tyOmoduleNm) of
{ ( _tyImentrelFilterMp) ->
(case (_tyImentrelFilterMp) of
{ _lhsOmentrelFilterMp ->
( _lhsOmentrelFilterMp) }) }) }))
-- TyAnn -------------------------------------------------------
{-
alternatives:
alternative Empty:
alternative Strictness:
child s : {Strictness}
alternative Mono:
-}
-- cata
sem_TyAnn :: TyAnn ->
T_TyAnn
sem_TyAnn (TyAnn_Empty) =
(sem_TyAnn_Empty)
sem_TyAnn (TyAnn_Strictness _s) =
(sem_TyAnn_Strictness _s)
sem_TyAnn (TyAnn_Mono) =
(sem_TyAnn_Mono)
-- semantic domain
type T_TyAnn = ( )
sem_TyAnn_Empty :: T_TyAnn
sem_TyAnn_Empty =
( )
sem_TyAnn_Strictness :: Strictness ->
T_TyAnn
sem_TyAnn_Strictness s_ =
( )
sem_TyAnn_Mono :: T_TyAnn
sem_TyAnn_Mono =
( )
-- TyQu --------------------------------------------------------
{-
alternatives:
alternative Forall:
child mlev : {MetaLev}
alternative Exists:
child mlev : {MetaLev}
alternative Plain:
child mlev : {MetaLev}
-}
-- cata
sem_TyQu :: TyQu ->
T_TyQu
sem_TyQu (TyQu_Forall _mlev) =
(sem_TyQu_Forall _mlev)
sem_TyQu (TyQu_Exists _mlev) =
(sem_TyQu_Exists _mlev)
sem_TyQu (TyQu_Plain _mlev) =
(sem_TyQu_Plain _mlev)
-- semantic domain
type T_TyQu = ( )
sem_TyQu_Forall :: MetaLev ->
T_TyQu
sem_TyQu_Forall mlev_ =
( )
sem_TyQu_Exists :: MetaLev ->
T_TyQu
sem_TyQu_Exists mlev_ =
( )
sem_TyQu_Plain :: MetaLev ->
T_TyQu
sem_TyQu_Plain mlev_ =
( )
-- TyVarCateg --------------------------------------------------
{-
alternatives:
alternative Plain:
alternative Fixed:
alternative Meta:
-}
-- cata
sem_TyVarCateg :: TyVarCateg ->
T_TyVarCateg
sem_TyVarCateg (TyVarCateg_Plain) =
(sem_TyVarCateg_Plain)
sem_TyVarCateg (TyVarCateg_Fixed) =
(sem_TyVarCateg_Fixed)
sem_TyVarCateg (TyVarCateg_Meta) =
(sem_TyVarCateg_Meta)
-- semantic domain
type T_TyVarCateg = ( )
sem_TyVarCateg_Plain :: T_TyVarCateg
sem_TyVarCateg_Plain =
( )
sem_TyVarCateg_Fixed :: T_TyVarCateg
sem_TyVarCateg_Fixed =
( )
sem_TyVarCateg_Meta :: T_TyVarCateg
sem_TyVarCateg_Meta =
( )