ppr_amode sty (CReg magic_id) = pprMagicId sty magic_id
-ppr_amode sty (CTemp uniq kind) = pprUnique uniq
+ppr_amode sty (CTemp uniq kind) = pprUnique uniq <> char '_'
ppr_amode sty (CLbl label kind) = pprCLabel sty label
\begin{code}
pprTempDecl :: Unique -> PrimRep -> Doc
pprTempDecl uniq kind
- = hcat [ pprPrimKind PprDebug kind, space, pprUnique uniq, semi ]
+ = hcat [ pprPrimKind PprDebug kind, space, pprUnique uniq, ptext SLIT("_;") ]
pprExternDecl :: CLabel -> PrimRep -> Doc
| otherwise = Implicit
-setNameProvenance :: Name -> Provenance -> Name -- Implicit Globals only
-setNameProvenance (Global uniq mod occ def Implicit) prov = Global uniq mod occ def prov
-setNameProvenance other_name prov = other_name
+setNameProvenance :: Name -> Provenance -> Name
+ -- setNameProvenance used to only change the provenance of Implicit-provenance things,
+ -- but that gives bad error messages for names defined twice in the same
+ -- module, so I changed it to set the proveance of *any* global (SLPJ Jun 97)
+setNameProvenance (Global uniq mod occ def _) prov = Global uniq mod occ def prov
+setNameProvenance other_name prov = other_name
getNameProvenance :: Name -> Provenance
getNameProvenance (Global uniq mod occ def prov) = prov
ppr_sig sty (Sig var ty _)
- = hang (hsep [ppr sty var, ptext SLIT("::")])
- 4 (ppr sty ty)
+ = sep [ppr sty var <+> ptext SLIT("::"),
+ nest 4 (ppr sty ty)]
ppr_sig sty (ClassOpSig var _ ty _)
- = hang (hsep [ppr sty (getOccName var), ptext SLIT("::")])
- 4 (ppr sty ty)
+ = sep [ppr sty (getOccName var) <+> ptext SLIT("::"),
+ nest 4 (ppr sty ty)]
ppr_sig sty (DeforestSig var _)
- = hang (hsep [text "{-# DEFOREST", ppr sty var])
- 4 (text "#-")
+ = hsep [text "{-# DEFOREST", ppr sty var, text "#-}"]
ppr_sig sty (SpecSig var ty using _)
- = hang (hsep [text "{-# SPECIALIZE", ppr sty var, ptext SLIT("::")])
- 4 (hsep [ppr sty ty, pp_using using, text "#-}"])
-
+ = sep [ hsep [text "{-# SPECIALIZE", ppr sty var, ptext SLIT("::")],
+ nest 4 (hsep [ppr sty ty, pp_using using, text "#-}"])
+ ]
where
pp_using Nothing = empty
pp_using (Just me) = hsep [char '=', ppr sty me]
ppr_sig sty (InlineSig var _)
-
= hsep [text "{-# INLINE", ppr sty var, text "#-}"]
ppr_sig sty (MagicUnfoldingSig var str _)
IMP_Ubiq()
import CmdLineOpts ( opt_PprUserLength )
-import Outputable ( Outputable(..), PprStyle(..), interppSP, ifnotPprForUser )
+import Outputable ( Outputable(..), PprStyle(..), pprQuote, interppSP )
import Kind ( Kind {- instance Outputable -} )
import Name ( nameOccName )
import Pretty
\begin{code}
instance (Outputable name) => Outputable (HsType name) where
- ppr = pprHsType
+ ppr sty ty = pprQuote sty $ \ sty -> pprHsType sty ty
instance (Outputable name) => Outputable (HsTyVar name) where
- ppr sty (UserTyVar name) = ppr_hs_tyname sty name
- ppr sty (IfaceTyVar name kind) = hsep [ppr_hs_tyname sty name, ptext SLIT("::"), ppr sty kind]
-
-
--- Here comes a rather gross hack.
--- We want to print data and class decls in interface files, from the original source
--- When we do, we want the type variables to come out with their original names, not
--- some new unique (or else interfaces wobble too much). So when we come to one of
--- these type variables we sneakily change the style to PprForUser!
-ppr_hs_tyname PprInterface tv_name = ppr (PprForUser opt_PprUserLength) tv_name
-ppr_hs_tyname other_sty tv_name = ppr other_sty tv_name
+ ppr sty (UserTyVar name) = ppr sty name
+ ppr sty (IfaceTyVar name kind) = pprQuote sty $ \ sty ->
+ hsep [ppr sty name, ptext SLIT("::"), ppr sty kind]
ppr_forall sty ctxt_prec [] [] ty
= ppr_mono_ty sty ctxt_prec ty
ppr_mono_ty sty ctxt_prec (HsPreForAllTy ctxt ty) = ppr_forall sty ctxt_prec [] ctxt ty
ppr_mono_ty sty ctxt_prec (HsForAllTy tvs ctxt ty) = ppr_forall sty ctxt_prec tvs ctxt ty
-ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr_hs_tyname sty name
+ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr sty name
ppr_mono_ty sty ctxt_prec (MonoFunTy ty1 ty2)
= let p1 = ppr_mono_ty sty pREC_FUN ty1
(hsep [ppr_mono_ty sty pREC_FUN fun_ty, ppr_mono_ty sty pREC_CON arg_ty])
ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty)
- = braces (hsep [ppr sty clas, ppr_mono_ty sty pREC_CON ty])
- -- Curlies are temporary
+ = hsep [ppr sty clas, ppr_mono_ty sty pREC_CON ty]
\end{code}
doIt :: ([CoreToDo], [StgToDo]) -> String -> IO ()
doIt (core_cmds, stg_cmds) input_pgm
- = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.03, for Haskell 1.4" "" >>
+ = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.04, for Haskell 1.4" "" >>
-- ******* READER
show_pass "Reader" >>
Unique{-instance Ord3-}
)
import UniqSupply ( getUnique, returnUs, thenUs, SYN_IE(UniqSM) )
+import UniqFM ( Uniquable(..) )
import Util ( panic, Ord3(..) )
\end{code}
}
;
-topdecl : typed { $$ = $1; }
- | datad { $$ = $1; }
- | newtd { $$ = $1; }
- | classd { $$ = $1; }
- | instd { $$ = $1; }
- | defaultd { $$ = $1; }
+topdecl : typed { $$ = $1; FN = NULL; SAMEFN = 0; }
+ | datad { $$ = $1; FN = NULL; SAMEFN = 0; }
+ | newtd { $$ = $1; FN = NULL; SAMEFN = 0; }
+ | classd { $$ = $1; FN = NULL; SAMEFN = 0; }
+ | instd { $$ = $1; FN = NULL; SAMEFN = 0; }
+ | defaultd { $$ = $1; FN = NULL; SAMEFN = 0; }
| decl { $$ = $1; }
;
get (MonoFunTy ty1 ty2) acc = get ty1 (get ty2 acc)
get (MonoDictTy cls ty) acc = get ty acc
get (MonoTyVar tv) acc = insert tv acc
- get (HsPreForAllTy ctxt ty) acc = foldr (get . snd) (get ty acc) ctxt
- get (HsForAllTy tvs ctxt ty) acc = filter (`notElem` locals) $
- foldr (get . snd) (get ty acc) ctxt
+
+ -- In (All a => a -> a) -> Int, there are no free tyvars
+ -- We just assume that we quantify over all type variables mentioned in the context.
+ get (HsPreForAllTy ctxt ty) acc = filter (`notElem` locals) (get ty [])
+ ++ acc
+ where
+ locals = foldr (get . snd) [] ctxt
+
+ get (HsForAllTy tvs ctxt ty) acc = (filter (`notElem` locals) $
+ foldr (get . snd) (get ty []) ctxt)
+ ++ acc
where
locals = map getTyVarName tvs
import FiniteMap
import Outputable
import Unique ( Unique, unboundKey )
-import UniqFM ( Uniquable(..) )
+import UniqFM ( Uniquable(..), listToUFM, plusUFM_C )
import Maybes ( maybeToBool )
import UniqSupply
import SrcLoc ( SrcLoc, noSrcLoc )
-- If it's not in the cache we put it there with the correct provenance.
-- The idea is that, after all this, the cache
-- will contain a Name with the correct Provenance (i.e. Local)
+
+ -- OLD (now wrong) COMMENT:
+ -- "Actually, there's a catch. If this is the *second* binding for something
+ -- we want to allocate a *fresh* unique, rather than using the same Name as before.
+ -- Otherwise we don't detect conflicting definitions of the same top-level name!
+ -- So the only time we re-use a Name already in the cache is when it's one of
+ -- the Implicit magic-unique ones mentioned in the previous para"
+
+ -- This (incorrect) patch doesn't work for record decls, when we have
+ -- the same field declared in multiple constructors. With the above patch,
+ -- each occurrence got a new Name --- aargh!
--
- -- Actually, there's a catch. If this is the *second* binding for something
- -- we want to allocate a *fresh* unique, rather than using the same Name as before.
- -- Otherwise we don't detect conflicting definitions of the same top-level name!
- -- So the only time we re-use a Name already in the cache is when it's one of
- -- the Implicit magic-unique ones mentioned in the previous para
+ -- So I reverted to the simple caching method (no "second-binding" thing)
+ -- The multiple-local-binding case is now handled by improving the conflict
+ -- detection in plusNameEnv.
let
provenance = LocalDef (rec_exp_fn new_name) loc
(us', us1) = splitUniqSupply us
uniq = getUnique us1
key = (mod,occ)
new_name = case lookupFM cache key of
- Just name | is_implicit_prov
- -> setNameProvenance name provenance
- where
- is_implicit_prov = case getNameProvenance name of
- Implicit -> True
- other -> False
- other -> mkGlobalName uniq mod occ VanillaDefn provenance
-
+ Just name -> setNameProvenance name provenance
+ other -> mkGlobalName uniq mod occ VanillaDefn provenance
new_cache = addToFM cache key new_name
in
setNameSupplyRn (us', inst_ns, new_cache) `thenRn_`
=============== NameEnv ================
\begin{code}
plusNameEnvRn :: NameEnv -> NameEnv -> RnM s d NameEnv
-plusNameEnvRn n1 n2
- = mapRn (addErrRn.nameClashErr) (conflictsFM (/=) n1 n2) `thenRn_`
- returnRn (n1 `plusFM` n2)
+plusNameEnvRn env1 env2
+ = mapRn (addErrRn.nameClashErr) (conflictsFM conflicting_name env1 env2) `thenRn_`
+ returnRn (env1 `plusFM` env2)
addOneToNameEnv :: NameEnv -> RdrName -> Name -> RnM s d NameEnv
addOneToNameEnv env rdr_name name
= case lookupFM env rdr_name of
- Nothing -> returnRn (addToFM env rdr_name name)
- Just name2 -> addErrRn (nameClashErr (rdr_name, (name, name2))) `thenRn_`
+ Just name2 | conflicting_name name name2
+ -> addErrRn (nameClashErr (rdr_name, (name, name2))) `thenRn_`
returnRn env
+ Nothing -> returnRn (addToFM env rdr_name name)
+
+conflicting_name n1 n2 = (n1 /= n2) || (isLocallyDefinedName n1 && isLocallyDefinedName n2)
+ -- We complain of a conflict if one RdrName maps to two different Names,
+ -- OR if one RdrName maps to the same *locally-defined* Name. The latter
+ -- case is to catch two separate, local definitions of the same thing.
+ --
+ -- If a module imports itself then there might be a local defn and an imported
+ -- defn of the same name; in this case the names will compare as equal, but
+ -- will still have different provenances.
+
lookupNameEnv :: NameEnv -> RdrName -> Maybe Name
lookupNameEnv = lookupFM
=============== Avails ================
\begin{code}
-emptyModuleAvails :: ModuleAvails
-plusModuleAvails :: ModuleAvails -> ModuleAvails -> ModuleAvails
-lookupModuleAvails :: ModuleAvails -> Module -> Maybe [AvailInfo]
+mkExportAvails :: Bool -> Module -> [AvailInfo] -> ExportAvails
+mkExportAvails unqualified_import mod_name avails
+ = (mod_avail_env, entity_avail_env)
+ where
+ -- The "module M" syntax only applies to *unqualified* imports (1.4 Report, Section 5.1.1)
+ mod_avail_env | unqualified_import = unitFM mod_name avails
+ | otherwise = emptyFM
+
+ entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
+ name <- availEntityNames avail]
-emptyModuleAvails = emptyFM
-plusModuleAvails = plusFM_C (++)
-lookupModuleAvails = lookupFM
+plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails
+plusExportAvails (m1, e1) (m2, e2)
+ = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2)
\end{code}
import Outputable ( PprStyle(..) )
import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
import Unique ( Unique )
+import UniqFM ( UniqFM )
import FiniteMap ( FiniteMap, emptyFM, bagToFM )
import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
import UniqSet
-- or the same type/class/id, more than once. Hence a boring old list.
-- This allows us to report duplicates in just one place, namely plusRnEnv.
-type ModuleAvails = FiniteMap Module Avails
+type ExportAvails = (FiniteMap Module Avails, -- Used to figure out "module M" export specifiers
+ -- Includes avails only from *unqualified* imports
+ -- (see 1.4 Report Section 5.1.1)
+
+ UniqFM AvailInfo) -- Used to figure out all other export specifiers.
+ -- Maps a Name to the AvailInfo that contains it
+ -- NB: Contain bindings for class ops but
+ -- not constructors (see defn of availEntityNames)
+
data AvailInfo = NotAvailable
| Avail Name -- An ordinary identifier
else
-- COMBINE RESULTS
- -- We put the local env first, so that a local provenance
+ -- We put the local env second, so that a local provenance
-- "wins", even if a module imports itself.
foldlRn plusRnEnv emptyRnEnv imp_rn_envs `thenRn` \ imp_rn_env ->
- plusRnEnv local_rn_env imp_rn_env `thenRn` \ rn_env ->
+ plusRnEnv imp_rn_env local_rn_env `thenRn` \ rn_env ->
let
- all_avails :: ModuleAvails
- all_avails = foldr plusModuleAvails local_mod_avails imp_avails_s
+ export_avails :: ExportAvails
+ export_avails = foldr plusExportAvails local_mod_avails imp_avails_s
explicit_names :: NameSet -- locally defined or explicitly imported
explicit_names = foldr add_on emptyNameSet (local_avails : explicit_imports_s)
in
-- PROCESS EXPORT LISTS
- exportsFromAvail this_mod exports all_avails rn_env
+ exportsFromAvail this_mod exports export_avails rn_env
`thenRn` \ (export_fn, export_env) ->
-- RECORD THAT LOCALLY DEFINED THINGS ARE AVAILABLE
\begin{code}
importsFromImportDecl :: RdrNameImportDecl
- -> RnMG (RnEnv, ModuleAvails, [AvailInfo])
+ -> RnMG (RnEnv, ExportAvails, [AvailInfo])
importsFromImportDecl (ImportDecl mod qual_only as_source as_mod import_spec loc)
= pushSrcLocRn loc $
-> Maybe Module -- Optional "as M" part
-> ExportEnv -- What's imported
-> [AvailInfo] -- What's to be hidden
- -> RnMG (RnEnv, ModuleAvails)
+ -> RnMG (RnEnv, ExportAvails)
qualifyImports this_mod qual_imp unqual_imp as_mod (ExportEnv avails fixities) hides
=
-- Create the fixity env
fixity_env = foldl (add_fixity name_env2) emptyFixityEnv fixities
- -- The "module M" syntax only applies to *unqualified* imports (1.4 Report, Section 5.1.1)
- mod_avail_env | unqual_imp = unitFM qual_mod avails
- | otherwise = emptyFM
+ -- Create the export-availability info
+ export_avails = mkExportAvails unqual_imp qual_mod avails
in
- returnRn (RnEnv name_env2 fixity_env, mod_avail_env)
+ returnRn (RnEnv name_env2 fixity_env, export_avails)
where
qual_mod = case as_mod of
Nothing -> this_mod
\begin{code}
exportsFromAvail :: Module
-> Maybe [RdrNameIE] -- Export spec
- -> ModuleAvails
+ -> ExportAvails
-> RnEnv
-> RnMG (Name -> ExportFlag, ExportEnv)
-- Complains if two distinct exports have same OccName
-- Complains about exports items not in scope
-exportsFromAvail this_mod Nothing all_avails rn_env
- = exportsFromAvail this_mod (Just [IEModuleContents this_mod]) all_avails rn_env
+exportsFromAvail this_mod Nothing export_avails rn_env
+ = exportsFromAvail this_mod (Just [IEModuleContents this_mod]) export_avails rn_env
-exportsFromAvail this_mod (Just export_items) all_avails (RnEnv name_env fixity_env)
+exportsFromAvail this_mod (Just export_items)
+ (mod_avail_env, entity_avail_env)
+ (RnEnv name_env fixity_env)
= mapRn exports_from_item export_items `thenRn` \ avail_envs ->
foldlRn plusAvailEnv emptyAvailEnv avail_envs `thenRn` \ export_avail_env ->
let
returnRn (export_fn, ExportEnv export_avails export_fixities)
where
- full_avail_env :: UniqFM AvailInfo
- full_avail_env = addListToUFM_C plusAvail emptyUFM
- [(name, avail) | avail <- concat (eltsFM all_avails),
- name <- availEntityNames avail
- ]
-
- -- NB: full_avail_env will contain bindings for class ops but not constructors
- -- (see defn of availEntityNames)
-
exports_from_item :: RdrNameIE -> RnMG AvailEnv
exports_from_item ie@(IEModuleContents mod)
- = case lookupFM all_avails mod of
+ = case lookupFM mod_avail_env mod of
Nothing -> failWithRn emptyAvailEnv (modExportErr mod)
Just avails -> listToAvailEnv ie avails
where
maybe_in_scope = lookupNameEnv name_env (ieName ie)
Just name = maybe_in_scope
- maybe_avail = lookupUFM full_avail_env name
+ maybe_avail = lookupUFM entity_avail_env name
Just avail = maybe_avail
export_avail = filterAvail ie avail
enough_avail = case export_avail of {NotAvailable -> False; other -> True}
import Unique ( Unique )
import UniqSet ( SYN_IE(UniqSet) )
import UniqFM ( UniqFM, lookupUFM )
-import Util {- ( isIn, isn'tIn, thenCmp, removeDups, cmpPString,
- panic, assertPanic{- , pprTrace ToDo:rm-} ) -}
+import Util
+IMPORT_1_3(List(nub))
\end{code}
rnDecl `renames' declarations.
(classTyVarNotInOpTyErr clas_tyvar sig)
`thenRn_`
- -- Check that class tyvar *doesn't* appear in the sig's context
- checkRn (not (clas_tyvar `elemNameSet` ctxt_fvs))
- (classTyVarInOpCtxtErr clas_tyvar sig)
- `thenRn_`
-
returnRn (ClassOpSig op_name dm_name new_ty locn)
\end{code}
-- rnHsSigType is used for source-language type signatures,
-- which use *implicit* universal quantification.
+-- Given the signature C => T we universally quantify over FV(T) \ {in-scope-tyvars}
+--
+-- We insist that the universally quantified type vars is a superset of FV(C)
+-- It follows that FV(T) is a superset of FV(C), so that the context constrains
+-- no type variables that don't appear free in the tau-type part.
+
rnHsSigType doc_str full_ty@(HsPreForAllTy ctxt ty) -- From source code (no kinds on tyvars)
= getNameEnv `thenRn` \ name_env ->
let
- mentioned_tyvars = extractHsTyVars full_ty
- forall_tyvars = filter not_in_scope mentioned_tyvars
- not_in_scope tv = case lookupFM name_env tv of
- Nothing -> True
- Just _ -> False
-
- non_foralld_constrained = [tv | (clas, ty) <- ctxt,
- tv <- extractHsTyVars ty,
- not (tv `elem` forall_tyvars)
- ]
+ mentioned_tyvars = extractHsTyVars ty
+ forall_tyvars = filter (not . in_scope) mentioned_tyvars
+ in_scope tv = maybeToBool (lookupFM name_env tv)
+
+ constrained_tyvars = nub (concat (map (extractHsTyVars . snd) ctxt))
+ constrained_and_in_scope = filter in_scope constrained_tyvars
+ constrained_and_not_mentioned = filter (not . (`elem` mentioned_tyvars)) constrained_tyvars
+
+ -- Zap the context if there's a problem, to avoid duplicate error message.
+ ctxt' | null constrained_and_in_scope && null constrained_and_not_mentioned = ctxt
+ | otherwise = []
in
- checkRn (null non_foralld_constrained)
- (ctxtErr sig_doc non_foralld_constrained) `thenRn_`
+ checkRn (null constrained_and_in_scope)
+ (ctxtErr1 sig_doc constrained_and_in_scope) `thenRn_`
+ checkRn (null constrained_and_not_mentioned)
+ (ctxtErr2 sig_doc constrained_and_not_mentioned ty) `thenRn_`
(bindTyVarsRn sig_doc (map UserTyVar forall_tyvars) $ \ new_tyvars ->
- rnContext ctxt `thenRn` \ new_ctxt ->
+ rnContext ctxt' `thenRn` \ new_ctxt ->
rnHsType ty `thenRn` \ new_ty ->
returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
)
\begin{code}
derivingNonStdClassErr clas sty
- = hsep [ptext SLIT("non-standard class in deriving:"), ppr sty clas]
+ = hsep [ptext SLIT("non-standard class"), ppr sty clas, ptext SLIT("in deriving clause")]
classTyVarNotInOpTyErr clas_tyvar sig sty
- = hang (hcat [ptext SLIT("Class type variable `"),
+ = hang (hsep [ptext SLIT("Class type variable"),
ppr sty clas_tyvar,
- ptext SLIT("' does not appear in method signature:")])
- 4 (ppr sty sig)
-
-classTyVarInOpCtxtErr clas_tyvar sig sty
- = hang (hcat [ ptext SLIT("Class type variable `"), ppr sty clas_tyvar,
- ptext SLIT("' present in method's local overloading context:")])
+ ptext SLIT("does not appear in method signature")])
4 (ppr sty sig)
dupClassAssertWarn ctxt dups sty
allOfNonTyVar ty sty
= hsep [ptext SLIT("`All' applied to a non-type variable:"), ppr sty ty]
-ctxtErr doc tyvars sty
- = hsep [ptext SLIT("Context constrains type variable(s)"),
+ctxtErr1 doc tyvars sty
+ = hsep [ptext SLIT("Context constrains in-scope type variable(s)"),
hsep (punctuate comma (map (ppr sty) tyvars))]
- $$ nest 4 (ptext SLIT("in") <+> doc sty)
+ $$
+ nest 4 (ptext SLIT("in") <+> doc sty)
+
+ctxtErr2 doc tyvars ty sty
+ = (ptext SLIT("Context constrains type variable(s)")
+ <+> hsep (punctuate comma (map (ppr sty) tyvars)))
+ $$
+ nest 4 (vcat [ptext SLIT("that do not appear in") <+> ppr sty ty,
+ ptext SLIT("in") <+> doc sty])
\end{code}
--- /dev/null
+module Silly (
+ Array.accum
+ ) where
+import qualified Array
--- /dev/null
+-- Duplicate fields in record decls
+
+module OK where
+
+data X = A {a :: Int} | B {a :: Int}
+
+f x = x
+
+-- data Y = V {a :: Int}
+
+-- f y = y
--- /dev/null
+{- Check that the context of a type does not
+ constrain any in-scope variables, and only constrains
+ type variables free in the type.
+-}
+
+module Foo where
+
+instance Eq a => Eq Bool where
+ (==) = error "help"
+
+
+f :: Eq a => Int -> Int
+f x = x
+
+
+class Foo a where
+ op :: Eq a => a -> a
--- /dev/null
+{- This program crashed GHC 2.03
+
+ From: Marc van Dongen <dongen@cs.ucc.ie>
+ Date: Sat, 31 May 1997 14:35:40 +0100 (BST)
+
+ zonkIdOcc: g_aoQ
+
+ panic! (the `impossible' happened):
+ lookupBindC:no info!
+ for: g_aoQ
+ (probably: data dependencies broken by an optimisation pass)
+ static binds for:
+ Tmp.$d1{-rmM,x-}
+ local binds for:
+-}
+
+module Tmp( g ) where
+
+data AB p q = A
+ | B p q
+
+g :: (Ord p,Ord q) => (AB p q) -> Bool
+g (B _ _) = g A
+
SRC_RUNTEST_OPTS += -o1 $*.stdout -o2 $*.stderr -x 0
HC_OPTS += -noC -ddump-tc -dcore-lint -hi
+# Expect failure. Why aren't they in "should-fail"?
tc075_RUNTEST_OPTS += -x 1
tc080_RUNTEST_OPTS += -x 1
%.o : %.hs
%.o : %.hs
- $(RUNTEST) $(HC) $(RUNTEST_OPTS) -- $(HC_OPTS) -c $< -o $@ -osuf $(subst .,,$(suffix $@))
+ $(RUNTEST) $(HC) $(RUNTEST_OPTS) -- $(HC_OPTS) -c $< -o $@
all :: $(HS_OBJS)
--- /dev/null
+{-
+ From: Marc van Dongen <dongen@cs.ucc.ie>
+ Date: Sat, 31 May 1997 19:57:46 +0100 (BST)
+
+ panic! (the `impossible' happened):
+ tcLookupTyVar:a_r6F
+
+ Please report it as a compiler bug to glasgow-haskell-bugs@dcs.gla.ac.uk.
+
+
+If the instance definition for (*) at the end of this toy module
+is replaced by the definition that is commented, this all compiles
+fine. Strange, because the two implementations are equivalent modulo
+the theory {(*) = multiply}.
+
+Remove the `multiply :: a -> a -> a' part, and it compiles without
+problems.
+
+
+SPJ note: the type signature on "multiply" should be
+ multiply :: Group a => a -> a -> a
+
+-}
+
+module Rings( Group, Ring ) where
+
+import qualified Prelude( Ord(..), Eq(..), Num(..) )
+import Prelude hiding( Ord(..), Eq(..), Num(..), MonadZero( zero ) )
+
+class Group a where
+ compare :: a -> a -> Prelude.Ordering
+ fromInteger :: Integer -> a
+ (+) :: a -> a -> a
+ (-) :: a -> a -> a
+ zero :: a
+ one :: a
+ zero = fromInteger 0
+ one = fromInteger 1
+
+-- class (Group a) => Ring a where
+-- (*) :: a -> a -> a
+-- (*) a b =
+-- case (compare a zero) of
+-- EQ -> zero
+-- LT -> zero - ((*) (zero - a) b)
+-- GT -> case compare a one of
+-- EQ -> b
+-- _ -> b + ((*) (a - one) b)
+
+class (Group a) => Ring a where
+ (*) :: a -> a -> a
+ (*) a b = multiply a b
+ where multiply :: Group a => a -> a ->a
+ multiply a b
+ = case (compare a zero) of
+ EQ -> zero
+ LT -> zero - (multiply (zero - a) b)
+ GT -> case compare a one of
+ EQ -> b
+ _ -> b + (multiply (a - one) b)
--- /dev/null
+module SOL where
+
+import GlaExts
+
+data SeqView t a = Null
+ | Cons a (t a)
+
+class PriorityQueue q where
+ empty :: (Ord a) => q a
+ single :: (Ord a) => a -> q a
+ insert :: (Ord a) => a -> q a -> q a
+ meld :: (Ord a) => q a -> q a -> q a
+ splitMin :: (Ord a) => q a -> SeqView q a
+ insert a q = single a `meld` q
+
+toOrderedList q = case splitMin q of
+ Null -> []
+ Cons a q -> a : toOrderedList q
+
+insertMany x q = foldr insert q x
+pqSort q x = toOrderedList (insertMany x q)
+
+check :: (PriorityQueue q) => (Ord a => q a) -> IO ()
+check empty = do
+ putStr "*** sorting\n"
+ out (pqSort empty [1 .. 99])
+ out (pqSort empty [1.0, 1.1 ..99.9])
+
+out :: (Num a) => [a] -> IO ()
+out x | sum x == 0 = putStr "ok\n"
+ | otherwise = putStr "ok\n"
+
--- /dev/null
+-- Check that "->" is an instance of Eval
+
+module Foo where
+
+instance (Eq b) => Eq (a -> b) where
+ (==) f g = error "attempt to compare functions"
+
+ -- Since Eval is a superclass of Num this fails
+ -- unless -> is an instance of Eval
+instance (Num b) => Num (a -> b) where
+ f + g = \a -> f a + g a
+ f - g = \a -> f a - g a
+ f * g = \a -> f a * g a
+ negate f = \a -> negate (f a)
+ abs f = \a -> abs (f a)
+ signum f = \a -> signum (f a)
+ fromInteger n = \a -> fromInteger n
+ fromInt n = \a -> fromInt n
ppr_inst sty ppr_orig (Dict u clas ty orig loc)
= hang (ppr_orig orig loc)
- 4 (hsep [ppr sty clas, pprParendGenType sty ty, show_uniq sty u])
+ 4 (pprQuote sty $ \ sty ->
+ hsep [ppr sty clas, pprParendGenType sty ty, show_uniq sty u])
ppr_inst sty ppr_orig (Method u id tys rho orig loc)
= hang (ppr_orig orig loc)
- 4 (hsep [ppr sty id, ptext SLIT("at"), interppSP sty tys, show_uniq sty u])
+ 4 (hsep [ppr sty id, ptext SLIT("at"),
+ pprQuote sty $ \ sty -> interppSP sty tys,
+ show_uniq sty u])
show_uniq PprDebug u = ppr PprDebug u
show_uniq sty u = empty
other -> ([], [], poly_ty)
(class_name, inst_ty) = case dict_ty of
MonoDictTy cls ty -> (cls,ty)
- other -> pprPanic "Malformed intance decl" (ppr PprDebug poly_ty)
+ other -> pprPanic "Malformed instance decl" (ppr PprDebug poly_ty)
\end{code}
import {-# SOURCE #-} TcGRHSs ( tcGRHSsAndBinds )
#endif
-import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
- HsExpr, HsBinds, OutPat, Fake, Stmt,
+import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
+ HsExpr(..), HsBinds(..), MonoBinds(..), OutPat, Fake, Stmt,
+ Sig, HsLit, DoOrListComp, Fixity, HsType, ArithSeqInfo,
collectPatBinders, pprMatch )
import RnHsSyn ( SYN_IE(RenamedMatch) )
import TcHsSyn ( TcIdOcc(..), SYN_IE(TcMatch) )
import TcEnv ( newMonoIds )
import TcPat ( tcPat )
import TcType ( SYN_IE(TcType), TcMaybe, zonkTcType )
+import TcSimplify ( bindInstsOfLocalFuns )
import Unify ( unifyTauTy, unifyTauTyList )
import Name ( Name {- instance Outputable -} )
import Kind ( Kind, mkTypeKind )
import Pretty
-import Type ( isTyVarTy, mkFunTy, getFunTy_maybe )
+import Type ( isTyVarTy, isTauTy, mkFunTy, getFunTy_maybe )
import Util
import Outputable
#if __GLASGOW_HASKELL__ >= 202
Just (arg_ty,rest_ty) -> -- It's a function type!
let binders = collectPatBinders pat
in
- newMonoIds binders mkTypeKind (\ _ ->
+ newMonoIds binders mkTypeKind (\ mono_ids ->
tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
unifyTauTy pat_ty arg_ty `thenTc_`
tcMatchExpected rest_ty match `thenTc` \ (match', lie_match) ->
- returnTc (PatMatch pat' match',
- plusLIE lie_pat lie_match)
+
+ -- In case there are any polymorpic, overloaded binders in the pattern
+ -- (which can happen in the case of rank-2 type signatures, or data constructors
+ -- with polymorphic arguments), we must dd a bindInstsOfLocalFns here
+ --
+ -- 99% of the time there are no bindings. In the unusual case we
+ -- march down the match to dump them in the right place (boring but easy).
+ bindInstsOfLocalFuns lie_match mono_ids `thenTc` \ (lie_match', inst_mbinds) ->
+ let
+ inst_binds = MonoBind inst_mbinds [] False
+ match'' = case inst_mbinds of
+ EmptyMonoBinds -> match'
+ other -> glue_on match'
+ glue_on (PatMatch p m) = PatMatch p (glue_on m)
+ glue_on (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
+ = (GRHSMatch (GRHSsAndBindsOut grhss
+ (inst_binds `ThenBinds` binds)
+ ty))
+ glue_on (SimpleMatch expr) = SimpleMatch (HsLet inst_binds expr)
+ in
+ returnTc (PatMatch pat' match'',
+ plusLIE lie_pat lie_match')
)
tcMatchExpected expected_ty (GRHSMatch grhss_and_binds)
= tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
+ checkTc (isTauTy expected_ty)
+ lurkingRank2SigErr `thenTc_`
unifyTauTy expected_ty grhss_ty `thenTc_`
returnTc (GRHSMatch grhss_and_binds', lie)
\begin{code}
varyingArgsErr name matches sty
= sep [ptext SLIT("Varying number of arguments for function"), ppr sty name]
+
+lurkingRank2SigErr sty
+ = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
\end{code}
-- It's worth doing plusFM specially, because we don't need
-- to do the lookup in fm1.
+-- FM2 over-rides FM1.
plusFM EmptyFM fm2 = fm2
plusFM fm1 EmptyFM = fm1
projects / ghc-hetmet.git / commitdiff