\begin{code}
module CStrings(
- CLabelString, isCLabelString,
+ CLabelString, isCLabelString, pprCLabelString,
+
cSEP, pp_cSEP,
stringToC, charToC, pprFSInCStyle,
\begin{code}
type CLabelString = FAST_STRING -- A C label, completely unencoded
+pprCLabelString lbl = ptext lbl
+
isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label
isCLabelString lbl
= all ok (_UNPK_ lbl)
import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl )
import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
-import CStrings ( stringToC )
+import CStrings ( stringToC, pprCLabelString )
import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
import Literal ( Literal(..) )
import TyCon ( tyConDataCons )
ccall_fun_ty =
case op_str of
DynamicTarget u -> ptext SLIT("_ccall_fun_ty") <> ppr u
- StaticTarget x -> ptext x
+ StaticTarget x -> pprCLabelString x
ccall_res_ty =
case non_void_results of
data NewOrData
= NewType -- "newtype Blah ..."
| DataType -- "data Blah ..."
- | EnumType -- Enumeration; all constructors are nullary
deriving( Eq ) -- Needed because Demand derives Eq
\end{code}
mkTopName, mkIPName,
mkDerivedName, mkGlobalName, mkKnownKeyGlobal,
mkWiredInIdName, mkWiredInTyConName,
+ mkUnboundName, isUnboundName,
+
maybeWiredInIdName, maybeWiredInTyConName,
isWiredInName, hashName,
import CmdLineOpts ( opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC )
import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc )
-import Unique ( pprUnique, Unique, Uniquable(..), u2i )
+import Unique ( pprUnique, Unique, Uniquable(..), unboundKey, u2i )
import Outputable
import GlaExts
\end{code}
mkDerivedName f name uniq = name {n_uniq = uniq, n_occ = f (n_occ name)}
+-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly
+-- during compiler debugging.
+mkUnboundName :: RdrName -> Name
+mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc
+
+isUnboundName :: Name -> Bool
+isUnboundName name = getUnique name == unboundKey
+\end{code}
+
+\begin{code}
-- When we renumber/rename things, we need to be
-- able to change a Name's Unique to match the cached
-- one in the thing it's the name of. If you know what I mean.
unboxedPairDataCon,
mkUnboxedTupleTy, unboxedTupleCon
)
+import CStrings ( CLabelString )
import Unique ( Unique )
import VarSet ( varSetElems )
import Outputable
\end{verbatim}
\begin{code}
-dsCCall :: FAST_STRING -- C routine to invoke
+dsCCall :: CLabelString -- C routine to invoke
-> [CoreExpr] -- Arguments (desugared)
-> Bool -- True <=> might cause Haskell GC
-> Bool -- True <=> really a "_casm_"
import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs )
-- friends:
-import HsTypes ( HsType )
+import HsTypes ( HsType, cmpHsType )
import HsImpExp ( IE(..), ieName )
import CoreSyn ( CoreExpr )
import PprCore () -- Instances for Outputable
--others:
import Id ( Id )
-import NameSet ( NameSet, nameSetToList )
+import Name ( Name, isUnboundName )
+import NameSet ( NameSet, elemNameSet, nameSetToList )
import BasicTypes ( RecFlag(..), Fixity )
import Outputable
import Bag
import SrcLoc ( SrcLoc )
import Var ( TyVar )
+import Util ( thenCmp )
\end{code}
%************************************************************************
\end{code}
\begin{code}
+okBindSig :: NameSet -> Sig Name -> Bool
+okBindSig ns (ClassOpSig _ _ _ _ _) = False
+okBindSig ns sig = sigForThisGroup ns sig
+
+okClsDclSig :: NameSet -> Sig Name -> Bool
+okClsDclSig ns (Sig _ _ _) = False
+okClsDclSig ns sig = sigForThisGroup ns sig
+
+okInstDclSig :: NameSet -> Sig Name -> Bool
+okInstDclSig ns (Sig _ _ _) = False
+okInstDclSig ns (FixSig _) = False
+okInstDclSig ns (SpecInstSig _ _) = True
+okInstDclSig ns sig = sigForThisGroup ns sig
+
+sigForThisGroup ns sig
+ = case sigName sig of
+ Nothing -> False
+ Just n | isUnboundName n -> True -- Don't complain about an unbound name again
+ | otherwise -> n `elemNameSet` ns
+
sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name]
sigsForMe f sigs
= filter sig_for_me sigs
where
- sig_for_me (Sig n _ _) = f n
- sig_for_me (ClassOpSig n _ _ _ _) = f n
- sig_for_me (SpecSig n _ _) = f n
- sig_for_me (InlineSig n _ _) = f n
- sig_for_me (NoInlineSig n _ _) = f n
- sig_for_me (SpecInstSig _ _) = False
- sig_for_me (FixSig (FixitySig n _ _)) = f n
- sig_for_me
- (DeprecSig (Deprecation (IEModuleContents _) _) _) = False
- sig_for_me
- (DeprecSig (Deprecation d _) _) = f (ieName d)
+ sig_for_me sig = case sigName sig of
+ Nothing -> False
+ Just n -> f n
+
+sigName :: Sig name -> Maybe name
+sigName (Sig n _ _) = Just n
+sigName (ClassOpSig n _ _ _ _) = Just n
+sigName (SpecSig n _ _) = Just n
+sigName (InlineSig n _ _) = Just n
+sigName (NoInlineSig n _ _) = Just n
+sigName (FixSig (FixitySig n _ _)) = Just n
+sigName (DeprecSig (Deprecation d _) _) = case d of
+ IEModuleContents _ -> Nothing
+ other -> Just (ieName d)
+sigName other = Nothing
isFixitySig :: Sig name -> Bool
isFixitySig (FixSig _) = True
\end{code}
\begin{code}
+hsSigDoc (Sig _ _ loc) = (SLIT("type signature"),loc)
+hsSigDoc (ClassOpSig _ _ _ _ loc) = (SLIT("class-method type signature"), loc)
+hsSigDoc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
+hsSigDoc (InlineSig _ _ loc) = (SLIT("INLINE pragma"),loc)
+hsSigDoc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc)
+hsSigDoc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
+hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
+hsSigDoc (DeprecSig _ loc) = (SLIT("DEPRECATED pragma"), loc)
+\end{code}
+
+\begin{code}
instance (Outputable name) => Outputable (Sig name) where
ppr sig = ppr_sig sig
ppr_phase (Just n) = int n
\end{code}
+Checking for distinct signatures; oh, so boring
+
+
+\begin{code}
+cmpHsSig :: Sig Name -> Sig Name -> Ordering
+cmpHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
+cmpHsSig (DeprecSig (Deprecation ie1 _) _)
+ (DeprecSig (Deprecation ie2 _) _) = cmp_ie ie1 ie2
+cmpHsSig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 `compare` n2
+cmpHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 `compare` n2
+
+cmpHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2
+cmpHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _)
+ = -- may have many specialisations for one value;
+ -- but not ones that are exactly the same...
+ thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
+
+cmpHsSig other_1 other_2 -- Tags *must* be different
+ | (sig_tag other_1) _LT_ (sig_tag other_2) = LT
+ | otherwise = GT
+
+cmp_ie :: IE Name -> IE Name -> Ordering
+cmp_ie (IEVar n1 ) (IEVar n2 ) = n1 `compare` n2
+cmp_ie (IEThingAbs n1 ) (IEThingAbs n2 ) = n1 `compare` n2
+cmp_ie (IEThingAll n1 ) (IEThingAll n2 ) = n1 `compare` n2
+-- Hmmm...
+cmp_ie (IEThingWith n1 _) (IEThingWith n2 _) = n1 `compare` n2
+cmp_ie (IEModuleContents _ ) (IEModuleContents _ ) = EQ
+
+sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)
+sig_tag (SpecSig n1 _ _) = ILIT(2)
+sig_tag (InlineSig n1 _ _) = ILIT(3)
+sig_tag (NoInlineSig n1 _ _) = ILIT(4)
+sig_tag (SpecInstSig _ _) = ILIT(5)
+sig_tag (FixSig _) = ILIT(6)
+sig_tag (DeprecSig _ _) = ILIT(7)
+sig_tag _ = panic# "tag(RnBinds)"
+\end{code}
-- others:
import PprType
import {-# SOURCE #-} FunDeps ( pprFundeps )
-import CStrings ( CLabelString )
+import CStrings ( CLabelString, pprCLabelString )
import Outputable
import SrcLoc ( SrcLoc )
import Util
extNameStatic (ExtName f _) = f
extNameStatic Dynamic = panic "staticExtName: Dynamic - shouldn't ever happen."
-
instance Outputable ExtName where
ppr Dynamic = ptext SLIT("dynamic")
ppr (ExtName nm mb_mod) =
case mb_mod of { Nothing -> empty; Just m -> doubleQuotes (ptext m) } <+>
- doubleQuotes (ptext nm)
-
+ doubleQuotes (pprCLabelString nm)
\end{code}
%************************************************************************
import Type ( Type )
import Var ( TyVar, Id )
import DataCon ( DataCon )
+import CStrings ( CLabelString, pprCLabelString )
import SrcLoc ( SrcLoc )
\end{code}
(HsExpr id pat) -- (typechecked, of course)
(ArithSeqInfo id pat)
- | HsCCall FAST_STRING -- call into the C world; string is
+ | HsCCall CLabelString -- call into the C world; string is
[HsExpr id pat] -- the C function; exprs are the
-- arguments to pass.
Bool -- True <=> might cause Haskell
ppr_expr (HsCCall fun args _ is_asm result_ty)
= hang (if is_asm
- then ptext SLIT("_casm_ ``") <> ptext fun <> ptext SLIT("''")
- else ptext SLIT("_ccall_") <+> ptext fun)
+ then ptext SLIT("_casm_ ``") <> pprCLabelString fun <> ptext SLIT("''")
+ else ptext SLIT("_ccall_") <+> pprCLabelString fun)
4 (sep (map pprParendExpr args))
ppr_expr (HsSCC lbl expr)
)
import Unique ( Unique, mkPrimOpIdUnique )
import BasicTypes ( Arity )
+import CStrings ( CLabelString, pprCLabelString )
import PrelMods ( pREL_GHC, pREL_GHC_Name )
import Outputable
import Util ( assoc, zipWithEqual )
CallConv -- calling convention to use.
data CCallTarget
- = StaticTarget FAST_STRING -- An "unboxed" ccall# to `fn'.
+ = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'.
| DynamicTarget Unique -- First argument (an Addr#) is the function pointer
-- (unique is used to generate a 'typedef' to cast
-- the function pointer if compiling the ccall# down to
ppr_fun = case fun of
DynamicTarget _ -> text "\"\""
- StaticTarget fn -> ptext fn
+ StaticTarget fn -> pprCLabelString fn
\end{code}
import Name ( mkWiredInTyConName, mkWiredInIdName, mkSrcOccFS, mkWorkerOcc, dataName )
import DataCon ( DataCon, StrictnessMark(..), mkDataCon, dataConId )
import Var ( TyVar, tyVarKind )
-import TyCon ( TyCon, ArgVrcs, mkAlgTyCon, mkSynTyCon, mkTupleTyCon )
+import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkAlgTyCon, mkSynTyCon, mkTupleTyCon )
import BasicTypes ( Arity, NewOrData(..), RecFlag(..) )
import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys,
mkArrowKinds, boxedTypeKind, unboxedTypeKind,
alpha_ty = [alphaTy]
alpha_beta_tyvars = [alphaTyVar, betaTyVar]
-pcRecDataTyCon, pcNonRecDataTyCon, pcNonRecNewTyCon
+pcRecDataTyCon, pcNonRecDataTyCon
:: Unique{-TyConKey-} -> Module -> FAST_STRING
-> [TyVar] -> ArgVrcs -> [DataCon] -> TyCon
-pcRecDataTyCon = pcTyCon DataType Recursive
-pcNonRecDataTyCon = pcTyCon DataType NonRecursive
-pcNonRecNewTyCon = pcTyCon NewType NonRecursive
+pcRecDataTyCon = pcTyCon DataTyCon Recursive
+pcNonRecDataTyCon = pcTyCon DataTyCon NonRecursive
pcTyCon new_or_data is_rec key mod str tyvars argvrcs cons
= tycon
argvrcs
cons
[] -- No derivings
- Nothing -- Not a dictionary
new_or_data
is_rec
wrap_id = mkDataConWrapId data_con
\end{code}
+
%************************************************************************
%* *
\subsection[TysWiredIn-tuples]{The tuple types}
\begin{code}
boolTy = mkTyConTy boolTyCon
-boolTyCon = pcTyCon EnumType NonRecursive boolTyConKey
+boolTyCon = pcTyCon EnumTyCon NonRecursive boolTyConKey
pREL_BASE SLIT("Bool") [] [] [falseDataCon, trueDataCon]
falseDataCon = pcDataCon falseDataConKey pREL_BASE SLIT("False") [] [] [] boolTyCon
import {-# SOURCE #-} RnSource ( rnHsSigType )
import HsSyn
-import HsBinds ( sigsForMe )
+import HsBinds ( sigsForMe, cmpHsSig, sigName, hsSigDoc )
import RdrHsSyn
import RnHsSyn
import RnMonad
import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
-import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn,
+import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn, lookupOccRn,
warnUnusedLocalBinds, mapFvRn,
FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV,
unknownNameErr
)
import CmdLineOpts ( opt_WarnMissingSigs )
import Digraph ( stronglyConnComp, SCC(..) )
-import Name ( OccName, Name, nameOccName )
+import Name ( OccName, Name, nameOccName, mkUnboundName, isUnboundName )
import NameSet
import RdrName ( RdrName, rdrNameOcc )
import BasicTypes ( RecFlag(..), TopLevelFlag(..) )
rnTopMonoBinds mbinds sigs
= mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names ->
+ renameSigs (okBindSig (mkNameSet binder_names)) sigs `thenRn` \ (siglist, sig_fvs) ->
let
- binder_set = mkNameSet binder_names
- binder_occ_fm = listToFM [(nameOccName x,x) | x <- binder_names]
+ type_sig_vars = [n | Sig n _ _ <- siglist]
+ un_sigd_binders | opt_WarnMissingSigs = binder_names `minusList` type_sig_vars
+ | otherwise = []
in
- renameSigs opt_WarnMissingSigs binder_set
- (lookupSigOccRn binder_occ_fm) sigs `thenRn` \ (siglist, sig_fvs) ->
+ mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_`
+
rn_mono_binds siglist mbinds `thenRn` \ (final_binds, bind_fvs) ->
returnRn (final_binds, bind_fvs `plusFV` sig_fvs)
where
binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))
-
--- the names appearing in the sigs have to be bound by
--- this group's binders.
-lookupSigOccRn binder_occ_fm rdr_name
- = case lookupFM binder_occ_fm (rdrNameOcc rdr_name) of
- Nothing -> failWithRn (mkUnboundName rdr_name)
- (unknownNameErr rdr_name)
- Just x -> returnRn x
\end{code}
%************************************************************************
bindLocatedLocalsRn (text "a binding group") mbinders_w_srclocs
$ \ new_mbinders ->
let
- binder_set = mkNameSet new_mbinders
- binder_occ_fm = listToFM [(nameOccName x,x) | x <- new_mbinders]
-
- -- Weed out the fixity declarations that do not
- -- apply to any of the binders in this group.
- (sigs_for_me, fixes_not_for_me) = partition forLocalBind sigs
-
- forLocalBind (FixSig sig@(FixitySig name _ _ )) =
- isJust (lookupFM binder_occ_fm (rdrNameOcc name))
- forLocalBind _ = True
+ binder_set = mkNameSet new_mbinders
in
-- Rename the signatures
- renameSigs False binder_set
- (lookupSigOccRn binder_occ_fm) sigs_for_me `thenRn` \ (siglist, sig_fvs) ->
+ renameSigs (okBindSig binder_set) sigs `thenRn` \ (siglist, sig_fvs) ->
-- Report the fixity declarations in this group that
-- don't refer to any of the group's binders.
-- Then install the fixity declarations that do apply here
-- Notice that they scope over thing_inside too
- mapRn_ (unknownSigErr) fixes_not_for_me `thenRn_`
let
fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- siglist ]
in
signatures. We'd only need this if we wanted to report unused tyvars.
\begin{code}
-renameSigs :: Bool -- True => warn if (required) type signatures are missing.
- -> NameSet -- Set of names bound in this group
- -> (RdrName -> RnMS Name)
+renameSigs :: (RenamedSig -> Bool) -- OK-sig predicate
-> [RdrNameSig]
- -> RnMS ([RenamedSig], FreeVars) -- List of Sig constructors
+ -> RnMS ([RenamedSig], FreeVars)
+
+renameSigs ok_sig [] = returnRn ([], emptyFVs) -- Common shortcut
-renameSigs sigs_required binders lookup_occ_nm sigs
+renameSigs ok_sig sigs
= -- Rename the signatures
- mapFvRn (renameSig lookup_occ_nm) sigs `thenRn` \ (sigs', fvs) ->
+ mapFvRn renameSig sigs `thenRn` \ (sigs', fvs) ->
-- Check for (a) duplicate signatures
-- (b) signatures for things not in this group
- -- (c) optionally, bindings with no signature
let
- (goodies, dups) = removeDups cmp_sig (sigsForMe (not . isUnboundName) sigs')
- not_this_group = sigsForMe (not . (`elemNameSet` binders)) goodies
- type_sig_vars = [n | Sig n _ _ <- goodies]
- un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars
- | otherwise = []
+ in_scope = filter is_in_scope sigs'
+ is_in_scope sig = case sigName sig of
+ Just n -> not (isUnboundName n)
+ Nothing -> True
+ (not_dups, dups) = removeDups cmpHsSig in_scope
+ (goods, bads) = partition ok_sig not_dups
in
- mapRn_ dupSigDeclErr dups `thenRn_`
- mapRn_ unknownSigErr not_this_group `thenRn_`
- mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_`
- returnRn (sigs', fvs)
- -- bad ones and all:
- -- we need bindings of *some* sort for every name
+ mapRn_ unknownSigErr bads `thenRn_`
+ mapRn_ dupSigDeclErr dups `thenRn_`
+ returnRn (goods, fvs)
-- We use lookupOccRn in the signatures, which is a little bit unsatisfactory
-- because this won't work for:
-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
-- Doesn't seem worth much trouble to sort this.
-renameSig :: (RdrName -> RnMS Name) -> Sig RdrName -> RnMS (Sig Name, FreeVars)
+renameSig :: Sig RdrName -> RnMS (Sig Name, FreeVars)
-renameSig lookup_occ_nm (Sig v ty src_loc)
+renameSig (Sig v ty src_loc)
= pushSrcLocRn src_loc $
- lookup_occ_nm v `thenRn` \ new_v ->
+ lookupOccRn v `thenRn` \ new_v ->
rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) ->
returnRn (Sig new_v new_ty src_loc, fvs `addOneFV` new_v)
-renameSig _ (SpecInstSig ty src_loc)
+renameSig (SpecInstSig ty src_loc)
= pushSrcLocRn src_loc $
rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, fvs) ->
returnRn (SpecInstSig new_ty src_loc, fvs)
-renameSig lookup_occ_nm (SpecSig v ty src_loc)
+renameSig (SpecSig v ty src_loc)
= pushSrcLocRn src_loc $
- lookup_occ_nm v `thenRn` \ new_v ->
+ lookupOccRn v `thenRn` \ new_v ->
rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) ->
returnRn (SpecSig new_v new_ty src_loc, fvs `addOneFV` new_v)
-renameSig lookup_occ_nm (FixSig (FixitySig v fix src_loc))
+renameSig (FixSig (FixitySig v fix src_loc))
= pushSrcLocRn src_loc $
- lookup_occ_nm v `thenRn` \ new_v ->
+ lookupOccRn v `thenRn` \ new_v ->
returnRn (FixSig (FixitySig new_v fix src_loc), unitFV new_v)
-renameSig lookup_occ_nm (DeprecSig (Deprecation ie txt) src_loc)
+renameSig (DeprecSig (Deprecation ie txt) src_loc)
= pushSrcLocRn src_loc $
- renameIE lookup_occ_nm ie `thenRn` \ (new_ie, fvs) ->
+ renameIE lookupOccRn ie `thenRn` \ (new_ie, fvs) ->
returnRn (DeprecSig (Deprecation new_ie txt) src_loc, fvs)
-renameSig lookup_occ_nm (InlineSig v p src_loc)
+renameSig (InlineSig v p src_loc)
= pushSrcLocRn src_loc $
- lookup_occ_nm v `thenRn` \ new_v ->
+ lookupOccRn v `thenRn` \ new_v ->
returnRn (InlineSig new_v p src_loc, unitFV new_v)
-renameSig lookup_occ_nm (NoInlineSig v p src_loc)
+renameSig (NoInlineSig v p src_loc)
= pushSrcLocRn src_loc $
- lookup_occ_nm v `thenRn` \ new_v ->
+ lookupOccRn v `thenRn` \ new_v ->
returnRn (NoInlineSig new_v p src_loc, unitFV new_v)
\end{code}
= returnRn (IEModuleContents m, emptyFVs)
\end{code}
-Checking for distinct signatures; oh, so boring
-
-
-\begin{code}
-cmp_sig :: RenamedSig -> RenamedSig -> Ordering
-cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
-cmp_sig (DeprecSig (Deprecation ie1 _) _)
- (DeprecSig (Deprecation ie2 _) _) = cmp_ie ie1 ie2
-cmp_sig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 `compare` n2
-cmp_sig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 `compare` n2
-cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2
-cmp_sig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _)
- = -- may have many specialisations for one value;
- -- but not ones that are exactly the same...
- thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
-
-cmp_sig other_1 other_2 -- Tags *must* be different
- | (sig_tag other_1) _LT_ (sig_tag other_2) = LT
- | otherwise = GT
-
-cmp_ie :: IE Name -> IE Name -> Ordering
-cmp_ie (IEVar n1 ) (IEVar n2 ) = n1 `compare` n2
-cmp_ie (IEThingAbs n1 ) (IEThingAbs n2 ) = n1 `compare` n2
-cmp_ie (IEThingAll n1 ) (IEThingAll n2 ) = n1 `compare` n2
--- Hmmm...
-cmp_ie (IEThingWith n1 _) (IEThingWith n2 _) = n1 `compare` n2
-cmp_ie (IEModuleContents _ ) (IEModuleContents _ ) = EQ
-
-sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)
-sig_tag (SpecSig n1 _ _) = ILIT(2)
-sig_tag (InlineSig n1 _ _) = ILIT(3)
-sig_tag (NoInlineSig n1 _ _) = ILIT(4)
-sig_tag (SpecInstSig _ _) = ILIT(5)
-sig_tag (FixSig _) = ILIT(6)
-sig_tag (DeprecSig _ _) = ILIT(7)
-sig_tag _ = panic# "tag(RnBinds)"
-\end{code}
%************************************************************************
%* *
addErrRn (sep [ptext SLIT("Duplicate") <+> ptext what_it_is <> colon,
ppr sig])
where
- (what_it_is, loc) = sig_doc sig
+ (what_it_is, loc) = hsSigDoc sig
unknownSigErr sig
= pushSrcLocRn loc $
- addErrRn (sep [ptext SLIT("Misplaced"),
- ptext what_it_is <> colon,
+ addErrRn (sep [ptext SLIT("Misplaced") <+> ptext what_it_is <> colon,
ppr sig])
where
- (what_it_is, loc) = sig_doc sig
-
-sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc)
-sig_doc (ClassOpSig _ _ _ _ loc) = (SLIT("class-method type signature"), loc)
-sig_doc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
-sig_doc (InlineSig _ _ loc) = (SLIT("INLINE pragma"),loc)
-sig_doc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc)
-sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
-sig_doc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
-sig_doc (DeprecSig _ loc) = (SLIT("DEPRECATED pragma"), loc)
+ (what_it_is, loc) = hsSigDoc sig
missingSigWarn var
= sep [ptext SLIT("definition but no type signature for"), quotes (ppr var)]
import RnMonad
import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..),
ImportReason(..), getSrcLoc,
- mkLocalName, mkImportedLocalName, mkGlobalName,
+ mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName,
mkIPName, isSystemName,
nameOccName, setNameModule, nameModule,
pprOccName, isLocallyDefined, nameUnique, nameOccName,
)
import Name ( Name, OccName, NamedThing(..),
isLocallyDefinedName, nameModule, nameOccName,
- decode, mkLocalName
+ decode, mkLocalName, mkUnboundName
)
import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom,
mkModuleHiMaps, moduleName, mkVanillaModule, mkSearchPath
iDeprecs = emptyNameEnv
}
--- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly
--- during compiler debugging.
-mkUnboundName :: RdrName -> Name
-mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc
-
-isUnboundName :: Name -> Bool
-isUnboundName name = getUnique name == unboundKey
-
builtins :: FiniteMap (ModuleName,OccName) Name
builtins =
bagToFM (
let
-- First process the class op sigs, then the fixity sigs.
(op_sigs, non_op_sigs) = partition isClassOpSig sigs
- (fix_sigs, non_sigs) = partition isFixitySig non_op_sigs
in
checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs `thenRn` \ (sigs', sig_fvs) ->
- mapRn_ (unknownSigErr) non_sigs `thenRn_`
let
binders = mkNameSet [ nm | (ClassOpSig nm _ _ _ _) <- sigs' ]
in
- renameSigs False binders lookupOccRn fix_sigs `thenRn` \ (fixs', fix_fvs) ->
+ renameSigs (okClsDclSig binders) non_op_sigs `thenRn` \ (non_ops', fix_fvs) ->
-- Check the methods
checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
-- for instance decls.
ASSERT(isNoClassPragmas pragmas)
- returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (fixs' ++ sigs') mbinds'
+ returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds'
NoClassPragmas tname' dname' dwname' snames' src_loc),
sig_fvs `plusFV`
fix_fvs `plusFV`
) `thenRn` \ (mbinds', meth_fvs) ->
let
binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
-
- -- Delete sigs (&report) sigs that aren't allowed inside an
- -- instance decl:
- --
- -- + type signatures
- -- + fixity decls
- --
- (ok_sigs, not_ok_idecl_sigs) = partition okInInstDecl uprags
-
- okInInstDecl (FixSig _) = False
- okInInstDecl (Sig _ _ _) = False
- okInInstDecl _ = True
-
in
- -- You can't have fixity decls & type signatures
- -- within an instance declaration.
- mapRn_ unknownSigErr not_ok_idecl_sigs `thenRn_`
-
-- Rename the prags and signatures.
-- Note that the type variables are not in scope here,
-- so that instance Eq a => Eq (T a) where
-- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
-- works OK.
- renameSigs False binders lookupOccRn ok_sigs `thenRn` \ (new_uprags, prag_fvs) ->
+ renameSigs (okInstDclSig binders) uprags `thenRn` \ (new_uprags, prag_fvs) ->
getModeRn `thenRn` \ mode ->
(case mode of
Just fn' -> fn'
saturate :: Id -> [StgArg] -> Type -> ([StgArg] -> Type -> UniqSM StgExpr) -> UniqSM StgExpr
+ -- The type should be the type of (id args)
saturate fn args ty thing_inside
| excess_arity == 0 -- Saturated, so nothing to do
= thing_inside args ty
| otherwise -- An unsaturated constructor or primop; eta expand it
- = ASSERT2( excess_arity > 0 && excess_arity <= length extra_arg_tys,
- ppr fn <+> ppr args <+> ppr excess_arity )
+ = ASSERT2( excess_arity > 0 && excess_arity <= length arg_tys,
+ ppr fn <+> ppr args <+> ppr excess_arity <+> parens (ppr ty) <+> ppr arg_tys )
mapUs newStgVar extra_arg_tys `thenUs` \ arg_vars ->
thing_inside (args ++ map StgVarArg arg_vars) final_res_ty `thenUs` \ body ->
returnUs (StgLam ty arg_vars body)
)
import IdInfo ( InlinePragInfo(..) )
import CoreLint ( beginPass, endPass )
-import Type ( splitRepFunTys )
import ErrUtils ( dumpIfSet )
import SaAbsInt
import SaLib
tcExtendLocalValEnv
)
import TcBinds ( tcBindWithSigs, tcSpecSigs )
+import TcTyDecls ( mkNewTyConRep )
import TcUnify ( unifyKinds )
import TcMonad
import TcMonoType ( kcHsType, tcHsTopType, tcExtendTopTyVarScope,
)
import Var ( tyVarKind, TyVar )
import VarSet ( mkVarSet, emptyVarSet )
-import TyCon ( mkAlgTyCon )
+import TyCon ( AlgTyConFlavour(..), mkClassTyCon )
import Unique ( Unique, Uniquable(..) )
import Util
import Maybes ( seqMaybe )
dict_component_tys = sc_tys ++ op_tys
new_or_data = case dict_component_tys of
- [_] -> NewType
- other -> DataType
+ [_] -> NewTyCon (mkNewTyConRep tycon)
+ other -> DataTyCon
dict_con = mkDataCon datacon_name
[notMarkedStrict | _ <- dict_component_tys]
ppr tycon_name)
tycon_name
- tycon = mkAlgTyCon tycon_name
- class_kind
- tyvars
- [] -- No context
- argvrcs
- [dict_con] -- Constructors
- [] -- No derivings
- (Just clas) -- Yes! It's a dictionary
- new_or_data
- NonRecursive
+ tycon = mkClassTyCon tycon_name
+ class_kind
+ tyvars
+ argvrcs
+ dict_con -- Constructors
+ clas -- Yes! It's a dictionary
+ new_or_data
in
returnTc clas
\end{code}
import CoreUnfold
import CoreLint ( lintUnfolding )
import WorkWrap ( mkWrapper )
-import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) )
+import PrimOp ( PrimOp(..) )
import Id ( Id, mkId, mkVanillaId,
isDataConWrapId_maybe
module TcTyDecls (
tcTyDecl, kcTyDecl,
tcConDecl,
- mkImplicitDataBinds
+ mkImplicitDataBinds, mkNewTyConRep
) where
#include "HsVersions.h"
import Class ( Class )
import DataCon ( DataCon, dataConSig, mkDataCon, isNullaryDataCon,
dataConFieldLabels, dataConId, dataConWrapId,
- markedStrict, notMarkedStrict, markedUnboxed
+ markedStrict, notMarkedStrict, markedUnboxed, dataConRepType
)
import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId )
import FieldLabel
import Var ( Id, TyVar )
import Name ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique )
import Outputable
-import TyCon ( TyCon, ArgVrcs, mkSynTyCon, mkAlgTyCon,
- isSynTyCon, tyConDataCons, isNewTyCon
+import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkSynTyCon, mkAlgTyCon,
+ tyConDataCons, tyConTyVars,
+ isSynTyCon, isNewTyCon
)
-import Type ( getTyVar, tyVarsOfTypes,
+import Type ( getTyVar, tyVarsOfTypes, splitFunTy, applyTys,
mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
- mkTyVarTy, splitForAllTys, isForAllTy,
+ mkTyVarTy, splitForAllTys, isForAllTy, splitAlgTyConApp_maybe,
mkArrowKind, mkArrowKinds, boxedTypeKind,
isUnboxedType, Type, ThetaType, classesOfPreds
)
+import TysWiredIn ( unitTy )
import Var ( tyVarKind )
import VarSet ( intersectVarSet, isEmptyVarSet )
import Util ( equivClasses )
let
-- Construct the tycon
- real_data_or_new = case data_or_new of
- NewType -> NewType
- DataType | all isNullaryDataCon data_cons -> EnumType
- | otherwise -> DataType
+ flavour = case data_or_new of
+ NewType -> NewTyCon (mkNewTyConRep tycon)
+ DataType | all isNullaryDataCon data_cons -> EnumTyCon
+ | otherwise -> DataTyCon
argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name)
tycon_name
tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt' argvrcs
data_cons
derived_classes
- Nothing -- Not a dictionary
- real_data_or_new is_rec
+ flavour is_rec
in
returnTc tycon
where
returnTc clas
\end{code}
+\begin{code}
+mkNewTyConRep :: TyCon -> Type
+-- Find the representation type for this newtype TyCon
+-- The trick is to to deal correctly with recursive newtypes
+-- such as newtype T = MkT T
+
+mkNewTyConRep tc
+ = mkForAllTys tvs (loop [] (mkTyConApp tc (mkTyVarTys tvs)))
+ where
+ tvs = tyConTyVars tc
+ loop tcs ty = case splitAlgTyConApp_maybe ty of {
+ Nothing -> ty ;
+ Just (tc, tys, data_cons) | not (isNewTyCon tc) -> ty
+ | tc `elem` tcs -> unitTy
+ | otherwise ->
+
+ case splitFunTy (applyTys (dataConRepType (head data_cons)) tys) of
+ (rep_ty, _) -> loop (tc:tcs) rep_ty
+ }
+\end{code}
+
%************************************************************************
%* *
\begin{code}
module TyCon(
- TyCon, KindCon, SuperKindCon, ArgVrcs,
+ TyCon, KindCon, SuperKindCon, ArgVrcs, AlgTyConFlavour(..),
isFunTyCon, isUnLiftedTyCon, isBoxedTyCon, isProductTyCon,
isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
isEnumerationTyCon, isTupleTyCon, isUnboxedTupleTyCon,
- isRecursiveTyCon,
+ isRecursiveTyCon, newTyConRep,
mkAlgTyCon,
+ mkClassTyCon,
mkFunTyCon,
mkPrimTyCon,
mkTupleTyCon,
tyConKind :: Kind,
tyConArity :: Arity,
- tyConTyVars :: [TyVar],
- dataTyConTheta :: [(Class,[Type])],
- dataTyConArgVrcs :: ArgVrcs,
+ tyConTyVars :: [TyVar],
+ tyConArgVrcs :: ArgVrcs,
+ algTyConTheta :: [(Class,[Type])],
dataCons :: [DataCon],
-- Its data constructors, with fully polymorphic types
-- (b) in a quest for fast compilation we don't import
-- the constructors
- dataTyConDerivings :: [Class], -- Classes which have derived instances
+ algTyConDerivings :: [Class], -- Classes which have derived instances
- dataTyConClass_maybe :: (Maybe Class), -- Nothing for ordinary types;
+ algTyConFlavour :: AlgTyConFlavour,
+ algTyConRec :: RecFlag, -- Tells whether the data type is part of
+ -- a mutually-recursive group or not
+
+ algTyConClass_maybe :: Maybe Class -- Nothing for ordinary types;
-- Just c for the type constructor
-- for dictionaries of class c.
- algTyConFlavour :: NewOrData,
- algTyConRec :: RecFlag -- Tells whether the data type is part of
- -- a mutually-recursive group or not
+
}
| PrimTyCon { -- Primitive types; cannot be defined in Haskell
tyConName :: Name,
tyConKind :: Kind,
tyConArity :: Arity,
- primTyConArgVrcs :: ArgVrcs,
+ tyConArgVrcs :: ArgVrcs,
primTyConRep :: PrimRep
}
synTyConDefn :: Type, -- Right-hand side, mentioning these type vars.
-- Acts as a template for the expansion when
-- the tycon is applied to some types.
- synTyConArgVrcs :: ArgVrcs
+ tyConArgVrcs :: ArgVrcs
}
| KindCon { -- Type constructor at the kind level
type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)]
-- *NB*: this is tyvar variance info, *not*
-- termvar usage info.
+
+data AlgTyConFlavour
+ = DataTyCon -- Data type
+ | EnumTyCon -- Special sort of enumeration type
+ | NewTyCon Type -- Newtype, with its *ultimate* representation type
+ -- By 'ultimate' I mean that the rep type is not itself
+ -- a newtype or type synonym.
+
+ -- The rep type has explicit for-alls for the tyvars of
+ -- the TyCon. Thus:
+ -- newtype T a = MkT [(a,Int)]
+ -- The rep type is forall a. [(a,Int)]
+ --
+ -- The rep type isn't entirely simple:
+ -- for a recursive newtype we pick () as the rep type
+ -- newtype T = MkT T
\end{code}
%************************************************************************
tyConArity = 2
}
-mkAlgTyCon name kind tyvars theta argvrcs cons derivs maybe_clas flavour rec
+mkAlgTyCon name kind tyvars theta argvrcs cons derivs flavour rec
= AlgTyCon {
- tyConName = name,
- tyConUnique = nameUnique name,
- tyConKind = kind,
- tyConArity = length tyvars,
- tyConTyVars = tyvars,
- dataTyConTheta = theta,
- dataTyConArgVrcs = argvrcs,
- dataCons = cons,
- dataTyConDerivings = derivs,
- dataTyConClass_maybe = maybe_clas,
- algTyConFlavour = flavour,
- algTyConRec = rec
+ tyConName = name,
+ tyConUnique = nameUnique name,
+ tyConKind = kind,
+ tyConArity = length tyvars,
+ tyConTyVars = tyvars,
+ tyConArgVrcs = argvrcs,
+ algTyConTheta = theta,
+ dataCons = cons,
+ algTyConDerivings = derivs,
+ algTyConClass_maybe = Nothing,
+ algTyConFlavour = flavour,
+ algTyConRec = rec
}
+mkClassTyCon name kind tyvars argvrcs con clas flavour
+ = AlgTyCon {
+ tyConName = name,
+ tyConUnique = nameUnique name,
+ tyConKind = kind,
+ tyConArity = length tyvars,
+ tyConTyVars = tyvars,
+ tyConArgVrcs = argvrcs,
+ algTyConTheta = [],
+ dataCons = [con],
+ algTyConDerivings = [],
+ algTyConClass_maybe = Just clas,
+ algTyConFlavour = flavour,
+ algTyConRec = NonRecursive
+ }
+
+
mkTupleTyCon name kind arity tyvars con boxed
= TupleTyCon {
tyConUnique = nameUnique name,
tyConUnique = nameUnique name,
tyConKind = kind,
tyConArity = arity,
- primTyConArgVrcs = arg_vrcs,
+ tyConArgVrcs = arg_vrcs,
primTyConRep = rep
}
tyConArity = arity,
tyConTyVars = tyvars,
synTyConDefn = rhs,
- synTyConArgVrcs = argvrcs
+ tyConArgVrcs = argvrcs
}
setTyConName tc name = tc {tyConName = name, tyConUnique = nameUnique name}
-- isDataTyCon returns False for @newtype@ and for unboxed tuples
isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data}) = case new_or_data of
- NewType -> False
+ NewTyCon _ -> False
other -> True
isDataTyCon (TupleTyCon {tyConBoxed = True}) = True
isDataTyCon other = False
-isNewTyCon (AlgTyCon {algTyConFlavour = NewType}) = True
-isNewTyCon other = False
+isNewTyCon (AlgTyCon {algTyConFlavour = NewTyCon _}) = True
+isNewTyCon other = False
+
+newTyConRep (AlgTyCon {algTyConFlavour = NewTyCon rep}) = Just rep
+newTyConRep other = Nothing
-- A "product" tycon
-- has *one* constructor,
isSynTyCon (SynTyCon {}) = True
isSynTyCon _ = False
-isEnumerationTyCon (AlgTyCon {algTyConFlavour = EnumType}) = True
-isEnumerationTyCon other = False
+isEnumerationTyCon (AlgTyCon {algTyConFlavour = EnumTyCon}) = True
+isEnumerationTyCon other = False
-- The unit tycon isn't classed as a tuple tycon
isTupleTyCon (TupleTyCon {tyConArity = arity, tyConBoxed = True}) = arity >= 2
\begin{code}
tyConDerivings :: TyCon -> [Class]
-tyConDerivings (AlgTyCon {dataTyConDerivings = derivs}) = derivs
-tyConDerivings other = []
+tyConDerivings (AlgTyCon {algTyConDerivings = derivs}) = derivs
+tyConDerivings other = []
\end{code}
\begin{code}
tyConTheta :: TyCon -> [(Class, [Type])]
-tyConTheta (AlgTyCon {dataTyConTheta = theta}) = theta
+tyConTheta (AlgTyCon {algTyConTheta = theta}) = theta
-- should ask about anything else
\end{code}
tyConArgVrcs_maybe :: TyCon -> Maybe ArgVrcs
tyConArgVrcs_maybe (FunTyCon {} ) = Just [(False,True),(True,False)]
-tyConArgVrcs_maybe (AlgTyCon {dataTyConArgVrcs = oi}) = Just oi
-tyConArgVrcs_maybe (PrimTyCon {primTyConArgVrcs = oi}) = Just oi
+tyConArgVrcs_maybe (AlgTyCon {tyConArgVrcs = oi}) = Just oi
+tyConArgVrcs_maybe (PrimTyCon {tyConArgVrcs = oi}) = Just oi
tyConArgVrcs_maybe (TupleTyCon {tyConArity = arity }) = Just (replicate arity (True,False))
-tyConArgVrcs_maybe (SynTyCon {synTyConArgVrcs = oi }) = Just oi
+tyConArgVrcs_maybe (SynTyCon {tyConArgVrcs = oi }) = Just oi
tyConArgVrcs_maybe _ = Nothing
\end{code}
\begin{code}
tyConClass_maybe :: TyCon -> Maybe Class
-tyConClass_maybe (AlgTyCon {dataTyConClass_maybe = maybe_cls}) = maybe_cls
-tyConClass_maybe other_tycon = Nothing
+tyConClass_maybe (AlgTyCon {algTyConClass_maybe = maybe_cls}) = maybe_cls
+tyConClass_maybe other_tycon = Nothing
\end{code}
import Class ( classTyCon, Class )
import TyCon ( TyCon,
isUnboxedTupleTyCon, isUnLiftedTyCon,
- isFunTyCon, isDataTyCon, isNewTyCon,
+ isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep,
isAlgTyCon, isSynTyCon, tyConArity,
tyConKind, tyConDataCons, getSynTyConDefn,
tyConPrimRep, tyConClass_maybe
repType looks through
(a) for-alls, and
(b) newtypes
-in addition to synonyms. It's useful in the back end where we're not
+ (c) synonyms
+It's useful in the back end where we're not
interested in newtypes anymore.
\begin{code}
repType :: Type -> Type
-repType (NoteTy _ ty) = repType ty
-repType (ForAllTy _ ty) = repType ty
-repType (TyConApp tc tys) | isNewTyCon tc = repType (new_type_rep tc tys)
-repType other_ty = other_ty
-
-
-typePrimRep :: Type -> PrimRep
-typePrimRep ty = case splitTyConApp_maybe (repType ty) of
- Just (tc, ty_args) -> tyConPrimRep tc
- other -> PtrRep
-
-splitNewType_maybe :: Type -> Maybe Type
--- Find the representation of a newtype, if it is one
--- Looks through multiple levels of newtype
-splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty
-splitNewType_maybe (TyConApp tc tys) | isNewTyCon tc = case splitNewType_maybe rep_ty of
- Just rep_ty' -> Just rep_ty'
- Nothing -> Just rep_ty
- where
- rep_ty = new_type_rep tc tys
-
-splitNewType_maybe other = Nothing
-
-new_type_rep :: TyCon -> [Type] -> Type
--- The representation type for (T t1 .. tn), where T is a newtype
--- Looks through one layer only
-new_type_rep tc tys
- = ASSERT( isNewTyCon tc )
- case splitFunTy_maybe (applyTys (dataConRepType (head (tyConDataCons tc))) tys) of
- Just (rep_ty, _) -> rep_ty
+repType (ForAllTy _ ty) = repType ty
+repType (NoteTy _ ty) = repType ty
+repType ty = case splitNewType_maybe ty of
+ Just ty' -> repType ty' -- Still re-apply repType in case of for-all
+ Nothing -> ty
splitRepFunTys :: Type -> ([Type], Type)
-- Like splitFunTys, but looks through newtypes and for-alls
where
split args (FunTy arg res) = split (arg:args) (repType res)
split args ty = (reverse args, ty)
+
+typePrimRep :: Type -> PrimRep
+typePrimRep ty = case repType ty of
+ TyConApp tc _ -> tyConPrimRep tc
+ FunTy _ _ -> PtrRep
+ AppTy _ _ -> PtrRep -- ??
+ TyVarTy _ -> PtrRep
+
+splitNewType_maybe :: Type -> Maybe Type
+-- Find the representation of a newtype, if it is one
+-- Looks through multiple levels of newtype, but does not look through for-alls
+splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty
+splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of
+ Just rep_ty -> ASSERT( length tys == tyConArity tc )
+ -- The assert should hold because repType should
+ -- only be applied to *types* (of kind *)
+ Just (applyTys rep_ty tys)
+ Nothing -> Nothing
+splitNewType_maybe other = Nothing
\end{code}
showDocWith :: Mode -> Doc -> String
showDocWith mode doc
- = fullRender PageMode 100 1.5 put "" doc
+ = fullRender mode 100 1.5 put "" doc
where
put (Chr c) s = c:s
put (Str s1) s2 = s1 ++ s2
projects / ghc-hetmet.git / commitdiff