Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Glasgow Haskell Compiler
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
0
Merge Requests
0
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
Packages & Registries
Packages & Registries
Package Registry
Container Registry
Analytics
Analytics
CI / CD
Code Review
Insights
Issue
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
461f1fb5
Commit
461f1fb5
authored
Feb 09, 2000
by
lewie
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[project @ 2000-02-09 18:32:09 by lewie]
Misc. fixes to implicit parameters support.
parent
0198d561
Changes
16
Hide whitespace changes
Inline
Side-by-side
Showing
16 changed files
with
77 additions
and
39 deletions
+77
-39
ghc/compiler/basicTypes/Name.lhs
ghc/compiler/basicTypes/Name.lhs
+3
-1
ghc/compiler/hsSyn/HsExpr.lhs
ghc/compiler/hsSyn/HsExpr.lhs
+1
-1
ghc/compiler/hsSyn/HsTypes.lhs
ghc/compiler/hsSyn/HsTypes.lhs
+3
-1
ghc/compiler/main/MkIface.lhs
ghc/compiler/main/MkIface.lhs
+10
-4
ghc/compiler/parser/Lex.lhs
ghc/compiler/parser/Lex.lhs
+1
-1
ghc/compiler/parser/ParseUtil.lhs
ghc/compiler/parser/ParseUtil.lhs
+12
-4
ghc/compiler/parser/Parser.y
ghc/compiler/parser/Parser.y
+6
-3
ghc/compiler/rename/ParseIface.y
ghc/compiler/rename/ParseIface.y
+3
-1
ghc/compiler/typecheck/Inst.lhs
ghc/compiler/typecheck/Inst.lhs
+15
-7
ghc/compiler/typecheck/TcBinds.lhs
ghc/compiler/typecheck/TcBinds.lhs
+1
-1
ghc/compiler/typecheck/TcExpr.lhs
ghc/compiler/typecheck/TcExpr.lhs
+5
-3
ghc/compiler/typecheck/TcImprove.lhs
ghc/compiler/typecheck/TcImprove.lhs
+1
-1
ghc/compiler/typecheck/TcMonoType.lhs
ghc/compiler/typecheck/TcMonoType.lhs
+1
-1
ghc/compiler/typecheck/TcSimplify.lhs
ghc/compiler/typecheck/TcSimplify.lhs
+5
-6
ghc/compiler/types/PprType.lhs
ghc/compiler/types/PprType.lhs
+2
-2
ghc/compiler/types/Type.lhs
ghc/compiler/types/Type.lhs
+8
-2
No files found.
ghc/compiler/basicTypes/Name.lhs
View file @
461f1fb5
...
...
@@ -137,7 +137,8 @@ mkIPName :: Unique -> OccName -> Name
mkIPName uniq occ
= Name { n_uniq = uniq,
n_sort = Local,
n_occ = mkIPOcc occ,
n_occ = occ,
-- ZZ is this an appropriate provinence?
n_prov = SystemProv }
------------------------- Wired in names -------------------------
...
...
@@ -240,6 +241,7 @@ all_toplev_ids_visible =
opt_EnsureSplittableC -- Splitting requires visiblilty
\end{code}
\begin{code}
setNameProvenance :: Name -> Provenance -> Name
-- setNameProvenance used to only change the provenance of
...
...
ghc/compiler/hsSyn/HsExpr.lhs
View file @
461f1fb5
...
...
@@ -213,7 +213,7 @@ pprExpr e = pprDeeper (ppr_expr e)
pprBinds b = pprDeeper (ppr b)
ppr_expr (HsVar v) = ppr v
ppr_expr (HsIPVar v) =
char '?' <>
ppr v
ppr_expr (HsIPVar v) =
{- char '?' <> -}
ppr v
ppr_expr (HsLit lit) = ppr lit
ppr_expr (HsLitOut lit _) = ppr lit
...
...
ghc/compiler/hsSyn/HsTypes.lhs
View file @
461f1fb5
...
...
@@ -52,6 +52,8 @@ data HsType name
| MonoTupleTy [HsType name] -- Element types (length gives arity)
Bool -- boxed?
| MonoIParamTy name (HsType name)
-- these next two are only used in interfaces
| MonoDictTy name -- Class
[HsType name]
...
...
@@ -135,7 +137,7 @@ pprHsPred :: (Outputable name) => HsPred name -> SDoc
pprHsPred (HsPClass clas tys)
= ppr clas <+> hsep (map pprParendHsType tys)
pprHsPred (HsPIParam n ty)
= hsep [
char '?' <>
ppr n, text "::", ppr ty]
= hsep [
{- char '?' <> -}
ppr n, text "::", ppr ty]
\end{code}
\begin{code}
...
...
ghc/compiler/main/MkIface.lhs
View file @
461f1fb5
...
...
@@ -50,7 +50,7 @@ import Class ( Class, classExtraBigSig )
import FieldLabel ( fieldLabelName, fieldLabelType )
import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType,
deNoteType, classesToPreds,
Type, ThetaType
Type, ThetaType
, PredType(..), ClassContext
)
import PprType
...
...
@@ -578,15 +578,21 @@ ppr_decl_context :: ThetaType -> SDoc
ppr_decl_context [] = empty
ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>")
ppr_decl_class_context ::
[(Class,[Type])]
-> SDoc
ppr_decl_class_context ::
ClassContext
-> SDoc
ppr_decl_class_context [] = empty
ppr_decl_class_context ctxt = pprIfaceClasses ctxt <+> ptext SLIT(" =>")
pprIfaceTheta :: ThetaType -> SDoc -- Use braces rather than parens in interface files
pprIfaceTheta [] = empty
pprIfaceTheta theta = braces (hsep (punctuate comma [pprPred p | p <- theta]))
pprIfaceTheta theta = braces (hsep (punctuate comma [ppr
Iface
Pred p | p <- theta]))
pprIfaceClasses :: [(Class,[Type])] -> SDoc
-- ZZ - not sure who uses this - i.e. whether IParams really show up or not
-- (it's not used to print normal value signatures)
pprIfacePred :: PredType -> SDoc
pprIfacePred (Class clas tys) = pprConstraint clas tys
pprIfacePred (IParam n ty) = char '?' <> ppr n <+> ptext SLIT("::") <+> ppr ty
pprIfaceClasses :: ClassContext -> SDoc
pprIfaceClasses [] = empty
pprIfaceClasses theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
\end{code}
...
...
ghc/compiler/parser/Lex.lhs
View file @
461f1fb5
...
...
@@ -595,7 +595,7 @@ lexToken cont glaexts buf =
cont (ITunknown "\NUL") (stepOn buf)
'?'# | flag glaexts && is_lower (lookAhead# buf 1#) ->
lex_ip cont (s
etCurrentPos# buf 1#
)
lex_ip cont (s
tepOn buf
)
c | is_digit c -> lex_num cont glaexts 0 buf
| is_symbol c -> lex_sym cont buf
| is_upper c -> lex_con cont glaexts buf
...
...
ghc/compiler/parser/ParseUtil.lhs
View file @
461f1fb5
...
...
@@ -136,13 +136,21 @@ checkInstType t
checkContext :: RdrNameHsType -> P RdrNameContext
checkContext (MonoTupleTy ts True)
= mapP (\t -> check
Assertion t []) ts `thenP` \c
s ->
returnP
(map (uncurry HsPClass) cs)
= mapP (\t -> check
Pred t []) ts `thenP` \p
s ->
returnP
ps
checkContext (MonoTyVar t) -- empty contexts are allowed
| t == unitTyCon_RDR = returnP []
checkContext t
= checkAssertion t [] `thenP` \(c,ts) ->
returnP [HsPClass c ts]
= checkPred t [] `thenP` \p ->
returnP [p]
checkPred :: RdrNameHsType -> [RdrNameHsType]
-> P (HsPred RdrName)
checkPred (MonoTyVar t) args@(_:_) | not (isRdrTyVar t)
= returnP (HsPClass t args)
checkPred (MonoTyApp l r) args = checkPred l (r:args)
checkPred (MonoIParamTy n ty) [] = returnP (HsPIParam n ty)
checkPred _ _ = parseError "Illegal class assertion"
checkAssertion :: RdrNameHsType -> [RdrNameHsType]
-> P (HsClassAssertion RdrName)
...
...
ghc/compiler/parser/Parser.y
View file @
461f1fb5
{-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.
19 2000/01/28 20:52:39
lewie Exp $
$Id: Parser.y,v 1.
20 2000/02/09 18:32:10
lewie Exp $
Haskell grammar.
...
...
@@ -35,6 +35,7 @@ import GlaExts
{-
-----------------------------------------------------------------------------
Conflicts: 14 shift/reduce
(note: it's currently 21 -- JRL, 31/1/2000)
8 for abiguity in 'if x then y else z + 1'
(shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
...
...
@@ -85,7 +86,6 @@ Conflicts: 14 shift/reduce
'then' { ITthen }
'type' { ITtype }
'where' { ITwhere }
'with' { ITwith }
'_scc_' { ITscc }
'forall' { ITforall } -- GHC extension keywords
...
...
@@ -94,6 +94,7 @@ Conflicts: 14 shift/reduce
'label' { ITlabel }
'dynamic' { ITdynamic }
'unsafe' { ITunsafe }
'with' { ITwith }
'stdcall' { ITstdcallconv }
'ccall' { ITccallconv }
'_ccall_' { ITccall (False, False, False) }
...
...
@@ -174,7 +175,8 @@ Conflicts: 14 shift/reduce
QCONID { ITqconid $$ }
QVARSYM { ITqvarsym $$ }
QCONSYM { ITqconsym $$ }
IPVARID { ITipvarid $$ }
IPVARID { ITipvarid $$ } -- GHC extension
PRAGMA { ITpragma $$ }
...
...
@@ -489,6 +491,7 @@ type :: { RdrNameHsType }
btype :: { RdrNameHsType }
: btype atype { MonoTyApp $1 $2 }
| IPVARID '::' type { MonoIParamTy (mkSrcUnqual ipName $1) $3 }
| atype { $1 }
atype :: { RdrNameHsType }
...
...
ghc/compiler/rename/ParseIface.y
View file @
461f1fb5
...
...
@@ -145,7 +145,8 @@ import Ratio ( (%) )
QCONID { ITqconid $$ }
QVARSYM { ITqvarsym $$ }
QCONSYM { ITqconsym $$ }
IPVARID { ITipvarid $$ }
IPVARID { ITipvarid $$ } -- GHC extension
PRAGMA { ITpragma $$ }
...
...
@@ -452,6 +453,7 @@ atype : qtc_name { MonoTyVar $1 }
| '(#' types0 '#)' { MonoTupleTy $2 False{-unboxed-} }
| '[' type ']' { MonoListTy $2 }
| '{' qcls_name atypes '}' { MonoDictTy $2 $3 }
| '{' IPVARID '::' type '}' { MonoIParamTy (mkSysUnqual ipName $2) $4 }
| '(' type ')' { $2 }
-- This one is dealt with via qtc_name
...
...
ghc/compiler/typecheck/Inst.lhs
View file @
461f1fb5
...
...
@@ -25,10 +25,11 @@ module Inst (
lookupInst, lookupSimpleInst, LookupInstResult(..),
isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
isDict, is
ClassDict, is
TyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
instBindingRequired, instCanBeGeneralised,
zonkInst, zonkFunDeps, zonkTvFunDeps, instToId, instToIdBndr,
zonkInst, zonkInsts, zonkFunDeps, zonkTvFunDeps,
instToId, instToIdBndr, ipToId,
InstOrigin(..), InstLoc, pprInstLoc
) where
...
...
@@ -52,7 +53,8 @@ import Class ( classInstEnv, Class )
import FunDeps ( instantiateFdClassTys )
import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
import Name ( OccName, Name, mkDictOcc, mkMethodOcc, getOccName, nameUnique )
import Name ( OccName, Name, mkDictOcc, mkMethodOcc, mkIPOcc,
getOccName, nameUnique )
import PprType ( pprPred )
import InstEnv ( InstEnv, lookupInstEnv )
import SrcLoc ( SrcLoc )
...
...
@@ -310,8 +312,11 @@ Predicates
~~~~~~~~~~
\begin{code}
isDict :: Inst -> Bool
isDict (Dict _
(Class _ _)
_) = True
isDict (Dict _
_
_) = True
isDict other = False
isClassDict :: Inst -> Bool
isClassDict (Dict _ (Class _ _) _) = True
isClassDict other = False
isMethodFor :: TcIdSet -> Inst -> Bool
isMethodFor ids (Method uniq id tys _ _ loc)
...
...
@@ -485,9 +490,7 @@ instToIdBndr :: Inst -> TcId
instToIdBndr (Dict u (Class clas ty) (_,loc,_))
= mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty) loc
instToIdBndr (Dict u (IParam n ty) (_,loc,_))
-- = mkUserLocal (mkIPOcc (getOccName n)) u (mkPredTy (IParam n ty)) loc
= mkUserLocal (getOccName n) (nameUnique n) (mkPredTy (IParam n ty)) loc
-- = mkVanillaId n ty
= ipToId n ty loc
instToIdBndr (Method u id tys theta tau (_,loc,_))
= mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
...
...
@@ -497,6 +500,9 @@ instToIdBndr (LitInst u list ty loc)
instToIdBndr (FunDep clas fds _)
= panic "FunDep escaped!!!"
ipToId n ty loc
= mkUserLocal (mkIPOcc (getOccName n)) (nameUnique n) (mkPredTy (IParam n ty)) loc
\end{code}
...
...
@@ -539,6 +545,8 @@ zonkInst (FunDep clas fds loc)
= zonkFunDeps fds `thenNF_Tc` \ fds' ->
returnNF_Tc (FunDep clas fds' loc)
zonkInsts insts = mapNF_Tc zonkInst insts
zonkFunDeps fds = mapNF_Tc zonkFd fds
where
zonkFd (ts1, ts2)
...
...
ghc/compiler/typecheck/TcBinds.lhs
View file @
461f1fb5
...
...
@@ -291,7 +291,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
-- SIMPLIFY THE LIE
tcExtendGlobalTyVars tyvars_not_to_gen (
let ips = getIPsOfLIE lie_req in
if null real_tyvars_to_gen_list &&
null ips
then
if null real_tyvars_to_gen_list &&
(null ips || not is_unrestricted)
then
-- No polymorphism, and no IPs, so no need to simplify context
returnTc (lie_req, EmptyMonoBinds, [])
else
...
...
ghc/compiler/typecheck/TcExpr.lhs
View file @
461f1fb5
...
...
@@ -25,7 +25,7 @@ import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
lieToList, listToLIE, tyVarsOfLIE, zonkLIE,
newOverloadedLit, newMethod, newIPDict,
instOverloadedFun, newDicts, newClassDicts,
partitionLIEbyMeth, getIPsOfLIE
partitionLIEbyMeth, getIPsOfLIE
, instToId, ipToId
)
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcInstId,
...
...
@@ -200,10 +200,11 @@ tcMonoExpr (HsVar name) res_ty
\begin{code}
tcMonoExpr (HsIPVar name) res_ty
-- ZZ What's the `id' used for here...
= let id = mkVanillaId name res_ty in
tcGetInstLoc (OccurrenceOf id) `thenNF_Tc` \ loc ->
newIPDict name res_ty loc `thenNF_Tc` \ ip ->
returnNF_Tc (HsIPVar
id
, unitLIE ip)
returnNF_Tc (HsIPVar
(instToId ip)
, unitLIE ip)
\end{code}
%************************************************************************
...
...
@@ -746,7 +747,8 @@ tcMonoExpr (HsWith expr binds) res_ty
tcIPBinds ((name, expr) : binds)
= newTyVarTy_OpenKind `thenTc` \ ty ->
let id = mkVanillaId name ty in
tcGetSrcLoc `thenTc` \ loc ->
let id = ipToId name ty loc in
tcMonoExpr expr ty `thenTc` \ (expr', lie) ->
zonkTcType ty `thenTc` \ ty' ->
tcIPBinds binds `thenTc` \ (binds', types, lie2) ->
...
...
ghc/compiler/typecheck/TcImprove.lhs
View file @
461f1fb5
...
...
@@ -12,7 +12,7 @@ import TcMonad
import TcType ( zonkTcType, zonkTcTypes )
import TcUnify ( unifyTauTyLists )
import Inst ( Inst, LookupInstResult(..),
lookupInst,
isDict,
getFunDepsOfLIE, getIPsOfLIE,
lookupInst, getFunDepsOfLIE, getIPsOfLIE,
zonkLIE, zonkFunDeps {- for debugging -} )
import InstEnv ( InstEnv ) -- Reqd for 4.02; InstEnv is a synonym, and
-- 4.02 doesn't "see" it soon enough
...
...
ghc/compiler/typecheck/TcMonoType.lhs
View file @
461f1fb5
...
...
@@ -198,13 +198,13 @@ tc_type_kind (HsForAllTy (Just tv_names) context ty)
-- f :: forall a. Num a => (# a->a, a->a #)
-- And we want these to get through the type checker
check ct@(Class c tys) | ambiguous = failWithTc (ambigErr (c,tys) tau)
| otherwise = returnTc ()
where ct_vars = tyVarsOfTypes tys
forall_tyvars = map varName in_scope_vars
tau_vars = tyVarsOfType tau
ambig ct_var = (varName ct_var `elem` forall_tyvars) &&
not (ct_var `elemUFM` tau_vars)
ambiguous = foldUFM ((||) . ambig) False ct_vars
check _ = returnTc ()
in
mapTc check theta `thenTc_`
returnTc (body_kind, mkSigmaTy tyvars theta tau)
...
...
ghc/compiler/typecheck/TcSimplify.lhs
View file @
461f1fb5
...
...
@@ -132,7 +132,8 @@ import TcHsSyn ( TcExpr, TcId,
import TcMonad
import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
tyVarsOfInst, tyVarsOfInsts,
isDict, isStdClassTyVarDict, isMethodFor, notFunDep,
isDict, isClassDict, isStdClassTyVarDict,
isMethodFor, notFunDep,
instToId, instBindingRequired, instCanBeGeneralised,
newDictFromOld,
getDictClassTys, getIPs,
...
...
@@ -220,8 +221,6 @@ tcSimplify str local_tvs wanted_lie
(irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds
ambig_tv_fn dict = tyVarsOfInst dict `minusVarSet` avail_tvs
in
-- pprTrace "tcS" (ppr (frees, irreds')) $
-- pprTrace "tcS bad" (ppr bad_guys) $
addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_`
...
...
@@ -288,7 +287,7 @@ tcSimplifyAndCheck str local_tvs given_lie wanted_lie
givens = lieToList given_lie
-- see comment on wanteds in tcSimplify
wanteds = filter notFunDep (lieToList wanted_lie)
given_dicts = filter isDict givens
given_dicts = filter is
Class
Dict givens
try_me inst
-- Does not constrain a local tyvar
...
...
@@ -722,7 +721,7 @@ addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
-- Invariant: the Inst is already in Avails.
addSuperClasses avails dict
| not (isDict dict)
| not (is
Class
Dict dict)
= returnNF_Tc avails
| otherwise -- It is a dictionary
...
...
@@ -1217,7 +1216,7 @@ addNoInstanceErr str givens dict
ptext SLIT("Probable cause:") <+>
vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict),
ptext SLIT("in") <+> str],
if isDict dict && all_tyvars then empty else
if is
Class
Dict dict && all_tyvars then empty else
ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)]
)
where
...
...
ghc/compiler/types/PprType.lhs
View file @
461f1fb5
...
...
@@ -69,7 +69,7 @@ pprParendKind = pprParendType
pprPred :: PredType -> SDoc
pprPred (Class clas tys) = pprConstraint clas tys
pprPred (IParam n ty) =
ppr n <+> ppr ty
pprPred (IParam n ty) =
hsep [ppr n, ptext SLIT("::"), ppr ty]
pprConstraint :: Class -> [Type] -> SDoc
pprConstraint clas tys = ppr clas <+> hsep (map (pprParendType) tys)
...
...
@@ -189,7 +189,7 @@ ppr_ty env ctxt_prec ty@(ForAllTy _ _)
<+> ptext SLIT("=>")
ppr_pred (Class clas tys) = ppr clas <+> hsep (map (ppr_ty env tYCON_PREC) tys)
ppr_pred (IParam n ty) = hsep [
char '?' <>
ppr n, text "::",
ppr_pred (IParam n ty) = hsep [
{- char '?' <> -}
ppr n, text "::",
ppr_ty env tYCON_PREC ty]
ppr_ty env ctxt_prec (FunTy ty1 ty2)
...
...
ghc/compiler/types/Type.lhs
View file @
461f1fb5
...
...
@@ -89,7 +89,7 @@ import Var ( TyVar, IdOrTyVar, UVar,
import VarEnv
import VarSet
import Name ( Name, NamedThing(..), mkLocalName, tidyOccName
,
import Name ( Name, NamedThing(..), mkLocalName, tidyOccName
)
import NameSet
import Class ( classTyCon, Class )
...
...
@@ -864,7 +864,7 @@ tidyType env@(tidy_env, subst) ty
go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
go_note note@(UsgNote _) = note -- Usage annotation is already tidy
go_note note@(UsgForAll _) = note -- Uvar binder is already tidy
go_note
note@(IPNote _) = note -- IP is already tidy
go_note
(IPNote n) = IPNote (tidyIPName n)
tidyTypes env tys = map (tidyType env) tys
\end{code}
...
...
@@ -888,6 +888,12 @@ tidyTopType :: Type -> Type
tidyTopType ty = tidyType emptyTidyEnv ty
\end{code}
\begin{code}
tidyIPName :: Name -> Name
tidyIPName name
= mkLocalName (getUnique name) (getOccName name) noSrcLoc
\end{code}
%************************************************************************
%* *
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment