idPrimRep, getInstIdModule,
getMentionedTyConsAndClassesFromId,
- dataConTag,
- dataConSig, getInstantiatedDataConSig,
+ dataConTag, dataConStrictMarks,
+ dataConSig, dataConArgTys,
dataConTyCon, dataConArity,
dataConFieldLabels,
import Maybes ( maybeToBool )
import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
isLocallyDefinedName, isPreludeDefinedName,
- nameOrigName,
- RdrName(..), Name
- )
-import FieldLabel ( fieldLabelName, FieldLabel{-instances-} )
-import Outputable ( isAvarop, isAconop, getLocalName,
+ nameOrigName, mkTupleDataConName,
+ isAvarop, isAconop, getLocalName,
isLocallyDefined, isPreludeDefined,
getOrigName, getOccName,
- isExported, ExportFlag(..)
+ isExported, ExportFlag(..),
+ RdrName(..), Name
)
+import FieldLabel ( fieldLabelName, FieldLabel{-instances-} )
import PragmaInfo ( PragmaInfo(..) )
import PrelMods ( pRELUDE_BUILTIN )
import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
import UniqFM
import UniqSet -- practically all of it
import UniqSupply ( getBuiltinUniques )
-import Unique ( mkTupleDataConUnique, pprUnique, showUnique,
+import Unique ( pprUnique, showUnique,
Unique{-instance Ord3-}
)
-import Util ( mapAccumL, nOfThem,
+import Util ( mapAccumL, nOfThem, zipEqual,
panic, panic#, pprPanic, assertPanic
)
\end{code}
= let
(inst_env, tyvars, tyvar_tys)
= instantiateTyVarTemplates tvs
- (map getItsUnique tvs)
+ (map uniqueOf tvs)
in
-- the "context" and "arg_tys" have TyVarTemplates in them, so
-- we instantiate those types to have the right TyVars in them
mkTupleCon arity
= Id unique ty (TupleConId n arity) NoPragmaInfo tuplecon_info
where
- n = panic "mkTupleCon: its Name (Id)"
- unique = mkTupleDataConUnique arity
+ n = mkTupleDataConName arity
+ unique = uniqueOf n
ty = mkSigmaTy tyvars []
(mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
tycon = mkTupleTyCon arity
BEND
where
tyvar_tmpls = take arity alphaTyVars
- (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getItsUnique tyvar_tmpls)
+ (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
-}
fIRST_TAG :: ConTag
dataConFieldLabels :: DataCon -> [FieldLabel]
dataConFieldLabels (Id _ _ (DataConId _ _ _ fields _ _ _ _) _ _) = fields
+dataConFieldLabels (Id _ _ (TupleConId _ _) _ _) = []
+
+dataConStrictMarks :: DataCon -> [StrictnessMark]
+dataConStrictMarks (Id _ _ (DataConId _ _ stricts _ _ _ _ _) _ _) = stricts
+dataConStrictMarks (Id _ _ (TupleConId _ arity) _ _)
+ = take arity (repeat NotMarkedStrict)
+
+dataConArgTys :: DataCon
+ -> [Type] -- Instantiated at these types
+ -> [Type] -- Needs arguments of these types
+dataConArgTys con_id inst_tys
+ = map (instantiateTy tenv) arg_tys
+ where
+ (tyvars, _, arg_tys, _) = dataConSig con_id
+ tenv = tyvars `zipEqual` inst_tys
\end{code}
\begin{code}
recordSelectorFieldLabel (Id _ _ (RecordSelId lbl) _ _) = lbl
\end{code}
-{- LATER
-dataConTyCon (Id _ _ _ (SpecId unspec tys _))
- = mkSpecTyCon (dataConTyCon unspec) tys
-
-dataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
- = (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon)
- where
- (tyvars, theta_ty, arg_tys, tycon) = dataConSig unspec
-
- ty_env = tyvars `zip` ty_maybes
-
- spec_tyvars = foldr nothing_tyvars [] ty_env
- nothing_tyvars (tyvar, Nothing) l = tyvar : l
- nothing_tyvars (tyvar, Just ty) l = l
-
- spec_env = foldr just_env [] ty_env
- just_env (tyvar, Nothing) l = l
- just_env (tyvar, Just ty) l = (tyvar, ty) : l
- spec_arg_tys = map (instantiateTauTy spec_env) arg_tys
-
- spec_theta_ty = if null theta_ty then []
- else panic "dataConSig:ThetaTy:SpecDataCon"
- spec_tycon = mkSpecTyCon tycon ty_maybes
--}
-\end{code}
-
-\begin{pseudocode}
-@getInstantiatedDataConSig@ takes a constructor and some types to which
-it is applied; it returns its signature instantiated to these types.
-
-\begin{code}
-getInstantiatedDataConSig ::
- DataCon -- The data constructor
- -- Not a specialised data constructor
- -> [TauType] -- Types to which applied
- -- Must be fully applied i.e. contain all types of tycon
- -> ([TauType], -- Types of dict args
- [TauType], -- Types of regular args
- TauType -- Type of result
- )
-
-getInstantiatedDataConSig data_con inst_tys
- = ASSERT(isDataCon data_con)
- let
- (tvs, theta, arg_tys, tycon) = dataConSig data_con
-
- inst_env = ASSERT(length tvs == length inst_tys)
- tvs `zip` inst_tys
-
- theta_tys = [ instantiateTy inst_env (mkDictTy c t) | (c,t) <- theta ]
- cmpnt_tys = [ instantiateTy inst_env arg_ty | arg_ty <- arg_tys ]
- result_ty = instantiateTy inst_env (applyTyCon tycon inst_tys)
- in
- -- Are the first/third results ever used?
- (theta_tys, cmpnt_tys, result_ty)
-\end{code}
Data type declarations are of the form:
\begin{verbatim}
getName this_id@(Id u _ details _ _)
= get details
where
- get (LocalId n _) = n
- get (SysLocalId n _) = n
- get (SpecPragmaId n _ _)= n
- get (ImportedId n) = n
- get (PreludeId n) = n
- get (TopLevId n) = n
- get (InstId n _) = n
+ get (LocalId n _) = n
+ get (SysLocalId n _) = n
+ get (SpecPragmaId n _ _) = n
+ get (ImportedId n) = n
+ get (PreludeId n) = n
+ get (TopLevId n) = n
+ get (InstId n _) = n
get (DataConId n _ _ _ _ _ _ _) = n
- get (TupleConId n _) = n
- get (RecordSelId l) = getName l
--- get _ = pprPanic "Id.Id.NamedThing.getName:" (pprId PprDebug this_id)
+ get (TupleConId n _) = n
+ get (RecordSelId l) = getName l
+ get (SuperDictSelId c sc) = panic "Id.getName.SuperDictSelId"
+ get (MethodSelId c op) = panic "Id.getName.MethodSelId"
+ get (DefaultMethodId c op _) = panic "Id.getName.DefaultMethodId"
+ get (DictFunId c ty _ _) = panic "Id.getName.DictFunId"
+ get (ConstMethodId c ty op _ _) = panic "Id.getName.ConstMethodId"
+ get (SpecId i tys _) = panic "Id.getName.SpecId"
+ get (WorkerId i) = panic "Id.getName.WorkerId"
{- LATER:
get (MethodSelId c op) = case (getOrigName c) of -- ToDo; better ???
projects / ghc-hetmet.git / blobdiff