From 2dd1686ba8bf463dae9cb438c2147b44cf8a6ba1 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 11 Feb 2002 09:27:22 +0000 Subject: [PATCH] [project @ 2002-02-11 09:27:21 by simonpj] ------------------------------ Towards kinded data type decls ------------------------------ Move towards being able to have 'kinded' data type decls. The burden of this commit, though, is to tidy up the parsing of data type decls. Previously we had data ctype '=' constrs where the 'ctype' is a completetely general polymorphic type. forall a. (Eq a) => T a Then a separate function checked that it was of a suitably restricted form. The reason for this is the usual thing --- it's hard to tell when looking at data Eq a => T a = ... whether you are reading the data type or the context when you have only got as far as 'Eq a'. However, the 'ctype' trick doesn't work if we want to allow data T (a :: * -> *) = ... So we have to parse the data type decl in a more serious way. That's what this commit does, and it makes the grammar look much nicer. The main new producion is tycl_hdr. --- ghc/compiler/parser/ParseUtil.lhs | 55 +++----- ghc/compiler/parser/Parser.y | 252 ++++++++++++++++++++----------------- ghc/compiler/parser/RdrHsSyn.lhs | 6 +- 3 files changed, 157 insertions(+), 156 deletions(-) diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 73f31fa..2ee9664 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -24,8 +24,9 @@ module ParseUtil ( , checkPrec -- String -> P String , checkContext -- HsType -> P HsContext + , checkPred -- HsType -> P HsPred + , checkTyVars -- [HsTyVar] -> P [HsType] , checkInstType -- HsType -> P HsType - , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName]) , checkPattern -- HsExp -> P HsPat , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat] , checkDo -- [Stmt] -> P [Stmt] @@ -112,24 +113,32 @@ checkInstType t ty -> checkDictTy ty [] `thenP` \ dict_ty-> returnP (HsForAllTy Nothing [] dict_ty) +checkTyVars :: [RdrNameHsTyVar] -> P [RdrNameHsType] +checkTyVars tvs = mapP chk tvs + where + chk (UserTyVar tv) = returnP (HsTyVar tv) + chk other = parseError "Illegal kinded type variable" + checkContext :: RdrNameHsType -> P RdrNameContext checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type - = mapP (\t -> checkPred t []) ts `thenP` \ps -> - returnP ps + = mapP checkPred ts checkContext (HsTyVar t) -- Empty context shows up as a unit type () | t == unitTyCon_RDR = returnP [] checkContext t - = checkPred t [] `thenP` \p -> + = checkPred t `thenP` \p -> returnP [p] -checkPred :: RdrNameHsType -> [RdrNameHsType] -> P (HsPred RdrName) -checkPred (HsTyVar t) args | not (isRdrTyVar t) - = returnP (HsClassP t args) -checkPred (HsAppTy l r) args = checkPred l (r:args) -checkPred (HsPredTy (HsIParam n ty)) [] = returnP (HsIParam n ty) -checkPred _ _ = parseError "Illegal class assertion" +checkPred :: RdrNameHsType -> P (HsPred RdrName) +checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty) +checkPred (HsAppTy l r) + = go l [r] + where + go (HsTyVar t) args | not (isRdrTyVar t) + = returnP (HsClassP t args) + go (HsAppTy l r) args = go l (r:args) + go _ _ = parseError "Illegal class assertion" checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) @@ -137,32 +146,6 @@ checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) checkDictTy (HsAppTy l r) args = checkDictTy l (r:args) checkDictTy _ _ = parseError "Malformed context in instance header" --- Put more comments! --- Checks that the lhs of a datatype declaration --- is of the form Context => T a b ... z -checkDataHeader :: String -- data/newtype/class - -> RdrNameHsType - -> P (RdrNameContext, RdrName, [RdrNameHsTyVar]) - -checkDataHeader s (HsForAllTy Nothing cs t) = - checkSimple s t [] `thenP` \(c,ts) -> - returnP (cs,c,map UserTyVar ts) -checkDataHeader s t = - checkSimple s t [] `thenP` \(c,ts) -> - returnP ([],c,map UserTyVar ts) - --- Checks the type part of the lhs of --- a data/newtype/class declaration -checkSimple :: String -> RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName])) -checkSimple s (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a - = checkSimple s l (a:xs) -checkSimple s (HsTyVar tycon) xs | not (isRdrTyVar tycon) = returnP (tycon,xs) - -checkSimple s (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) [] - | not (isRdrTyVar tycon) && isRdrTyVar t1 && isRdrTyVar t2 - = returnP (tycon,[t1,t2]) - -checkSimple s t _ = parseError ("Malformed " ++ s ++ " declaration") --------------------------------------------------------------------------- -- Checking statements in a do-expression diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index ec7af29..c9e2042 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.84 2002/02/11 08:20:44 chak Exp $ +$Id: Parser.y,v 1.85 2002/02/11 09:27:22 simonpj Exp $ Haskell grammar. @@ -348,23 +348,20 @@ topdecl :: { RdrBinding } -- Instead we just say b is out of scope { RdrHsDecl (TyClD (TySynonym (fst $3) (snd $3) $5 $1)) } - | srcloc 'data' ctype constrs deriving - {% checkDataHeader "data" $3 `thenP` \(cs,c,ts) -> - returnP (RdrHsDecl (TyClD - (mkTyData DataType cs c ts (reverse $4) (length $4) $5 $1))) } + | srcloc 'data' tycl_hdr constrs deriving + {% returnP (RdrHsDecl (TyClD + (mkTyData DataType $3 (reverse $4) (length $4) $5 $1))) } - | srcloc 'newtype' ctype '=' newconstr deriving - {% checkDataHeader "newtype" $3 `thenP` \(cs,c,ts) -> - returnP (RdrHsDecl (TyClD - (mkTyData NewType cs c ts [$5] 1 $6 $1))) } + | srcloc 'newtype' tycl_hdr '=' newconstr deriving + {% returnP (RdrHsDecl (TyClD + (mkTyData NewType $3 [$5] 1 $6 $1))) } - | srcloc 'class' ctype fds where - {% checkDataHeader "class" $3 `thenP` \(cs,c,ts) -> - let + | srcloc 'class' tycl_hdr fds where + {% let (binds,sigs) = cvMonoBindsAndSigs cvClassOpSig (groupBindings $5) in returnP (RdrHsDecl (TyClD - (mkClassDecl cs c ts $4 sigs (Just binds) $1))) } + (mkClassDecl $3 $4 sigs (Just binds) $1))) } | srcloc 'instance' inst_type where { let (binds,sigs) @@ -378,6 +375,114 @@ topdecl :: { RdrBinding } | '{-# RULES' rules '#-}' { $2 } | decl { $1 } +-- tycl_hdr parses the header of a type or class decl, +-- which takes the form +-- T a b +-- Eq a => T a +-- (Eq a, Ord b) => T a b +-- Rather a lot of inlining here, else we get reduce/reduce errors +tycl_hdr :: { (RdrNameContext, RdrName, [RdrNameHsTyVar]) } + : '(' types ')' '=>' tycon tyvars {% mapP checkPred $2 `thenP` \ cxt -> + returnP (cxt, $5, $6) } + | tycon tyvars '=>' tycon tyvars {% checkTyVars $2 `thenP` \ args -> + returnP ([HsClassP $1 args], $4, $5) } + | qtycon tyvars '=>' tycon tyvars {% checkTyVars $2 `thenP` \ args -> + returnP ([HsClassP $1 args], $4, $5) } + | tycon tyvars { ([], $1, $2) } + +decls :: { [RdrBinding] } + : decls ';' decl { $3 : $1 } + | decls ';' { $1 } + | decl { [$1] } + | {- empty -} { [] } + +decl :: { RdrBinding } + : fixdecl { $1 } + | valdef { $1 } + | '{-# INLINE' srcloc activation qvar '#-}' { RdrSig (InlineSig True $4 $3 $2) } + | '{-# NOINLINE' srcloc inverse_activation qvar '#-}' { RdrSig (InlineSig False $4 $3 $2) } + | '{-# SPECIALISE' srcloc qvar '::' sigtypes '#-}' + { foldr1 RdrAndBindings + (map (\t -> RdrSig (SpecSig $3 t $2)) $5) } + | '{-# SPECIALISE' srcloc 'instance' inst_type '#-}' + { RdrSig (SpecInstSig $4 $2) } + +wherebinds :: { RdrNameHsBinds } + : where { cvBinds cvValSig (groupBindings $1) } + +where :: { [RdrBinding] } + : 'where' decllist { $2 } + | {- empty -} { [] } + +declbinds :: { RdrNameHsBinds } + : decllist { cvBinds cvValSig (groupBindings $1) } + +decllist :: { [RdrBinding] } + : '{' decls '}' { $2 } + | layout_on decls close { $2 } + +fixdecl :: { RdrBinding } + : srcloc infix prec ops { foldr1 RdrAndBindings + [ RdrSig (FixSig (FixitySig n + (Fixity $3 $2) $1)) + | n <- $4 ] } + +----------------------------------------------------------------------------- +-- Transformation Rules + +rules :: { RdrBinding } + : rules ';' rule { $1 `RdrAndBindings` $3 } + | rules ';' { $1 } + | rule { $1 } + | {- empty -} { RdrNullBind } + +rule :: { RdrBinding } + : STRING activation rule_forall infixexp '=' srcloc exp + { RdrHsDecl (RuleD (HsRule $1 $2 $3 $4 $7 $6)) } + +activation :: { Activation } -- Omitted means AlwaysActive + : {- empty -} { AlwaysActive } + | explicit_activation { $1 } + +inverse_activation :: { Activation } -- Omitted means NeverActive + : {- empty -} { NeverActive } + | explicit_activation { $1 } + +explicit_activation :: { Activation } -- In brackets + : '[' INTEGER ']' { ActiveAfter (fromInteger $2) } + | '[' '~' INTEGER ']' { ActiveBefore (fromInteger $3) } + +rule_forall :: { [RdrNameRuleBndr] } + : 'forall' rule_var_list '.' { $2 } + | {- empty -} { [] } + +rule_var_list :: { [RdrNameRuleBndr] } + : rule_var { [$1] } + | rule_var rule_var_list { $1 : $2 } + +rule_var :: { RdrNameRuleBndr } + : varid { RuleBndr $1 } + | '(' varid '::' ctype ')' { RuleBndrSig $2 $4 } + +----------------------------------------------------------------------------- +-- Deprecations + +deprecations :: { RdrBinding } + : deprecations ';' deprecation { $1 `RdrAndBindings` $3 } + | deprecations ';' { $1 } + | deprecation { $1 } + | {- empty -} { RdrNullBind } + +-- SUP: TEMPORARY HACK, not checking for `module Foo' +deprecation :: { RdrBinding } + : srcloc depreclist STRING + { foldr RdrAndBindings RdrNullBind + [ RdrHsDecl (DeprecD (Deprecation n $3 $1)) | n <- $2 ] } + + +----------------------------------------------------------------------------- +-- Foreign import and export declarations + -- for the time being, the following accepts foreign declarations conforming -- to the FFI Addendum, Version 1.0 as well as pre-standard declarations -- @@ -491,97 +596,6 @@ fdecl2DEPRECATED -- left this one unchanged for the moment as type imports are not -- covered currently by the FFI standard -=chak -decls :: { [RdrBinding] } - : decls ';' decl { $3 : $1 } - | decls ';' { $1 } - | decl { [$1] } - | {- empty -} { [] } - -decl :: { RdrBinding } - : fixdecl { $1 } - | valdef { $1 } - | '{-# INLINE' srcloc activation qvar '#-}' { RdrSig (InlineSig True $4 $3 $2) } - | '{-# NOINLINE' srcloc inverse_activation qvar '#-}' { RdrSig (InlineSig False $4 $3 $2) } - | '{-# SPECIALISE' srcloc qvar '::' sigtypes '#-}' - { foldr1 RdrAndBindings - (map (\t -> RdrSig (SpecSig $3 t $2)) $5) } - | '{-# SPECIALISE' srcloc 'instance' inst_type '#-}' - { RdrSig (SpecInstSig $4 $2) } - -wherebinds :: { RdrNameHsBinds } - : where { cvBinds cvValSig (groupBindings $1) } - -where :: { [RdrBinding] } - : 'where' decllist { $2 } - | {- empty -} { [] } - -declbinds :: { RdrNameHsBinds } - : decllist { cvBinds cvValSig (groupBindings $1) } - -decllist :: { [RdrBinding] } - : '{' decls '}' { $2 } - | layout_on decls close { $2 } - -fixdecl :: { RdrBinding } - : srcloc infix prec ops { foldr1 RdrAndBindings - [ RdrSig (FixSig (FixitySig n - (Fixity $3 $2) $1)) - | n <- $4 ] } - ------------------------------------------------------------------------------ --- Transformation Rules - -rules :: { RdrBinding } - : rules ';' rule { $1 `RdrAndBindings` $3 } - | rules ';' { $1 } - | rule { $1 } - | {- empty -} { RdrNullBind } - -rule :: { RdrBinding } - : STRING activation rule_forall infixexp '=' srcloc exp - { RdrHsDecl (RuleD (HsRule $1 $2 $3 $4 $7 $6)) } - -activation :: { Activation } -- Omitted means AlwaysActive - : {- empty -} { AlwaysActive } - | explicit_activation { $1 } - -inverse_activation :: { Activation } -- Omitted means NeverActive - : {- empty -} { NeverActive } - | explicit_activation { $1 } - -explicit_activation :: { Activation } -- In brackets - : '[' INTEGER ']' { ActiveAfter (fromInteger $2) } - | '[' '~' INTEGER ']' { ActiveBefore (fromInteger $3) } - -rule_forall :: { [RdrNameRuleBndr] } - : 'forall' rule_var_list '.' { $2 } - | {- empty -} { [] } - -rule_var_list :: { [RdrNameRuleBndr] } - : rule_var { [$1] } - | rule_var rule_var_list { $1 : $2 } - -rule_var :: { RdrNameRuleBndr } - : varid { RuleBndr $1 } - | '(' varid '::' ctype ')' { RuleBndrSig $2 $4 } - ------------------------------------------------------------------------------ --- Deprecations - -deprecations :: { RdrBinding } - : deprecations ';' deprecation { $1 `RdrAndBindings` $3 } - | deprecations ';' { $1 } - | deprecation { $1 } - | {- empty -} { RdrNullBind } - --- SUP: TEMPORARY HACK, not checking for `module Foo' -deprecation :: { RdrBinding } - : srcloc depreclist STRING - { foldr RdrAndBindings RdrNullBind - [ RdrHsDecl (DeprecD (Deprecation n $3 $1)) | n <- $2 ] } - ------------------------------------------------------------------------------ --- Foreign declarations callconv :: { CallConv } : 'stdcall' { CCall StdCallConv } @@ -644,6 +658,13 @@ ctype :: { RdrNameHsType } -- A type of form (context => type) is an *implicit* HsForAllTy | type { $1 } +-- We parse a context as a btype so that we don't get reduce/reduce +-- errors in ctype. The basic problem is that +-- (Eq a, Ord a) +-- looks so much like a tuple type. We can't tell until we find the => +context :: { RdrNameContext } + : btype {% checkContext $1 } + type :: { RdrNameHsType } : gentype '->' type { HsFunTy $1 $3 } | ipvar '::' type { mkHsIParamTy $1 $3 } @@ -688,7 +709,7 @@ simpletype :: { (RdrName, [RdrNameHsTyVar]) } : tycon tyvars { ($1, reverse $2) } tyvars :: { [RdrNameHsTyVar] } - : tyvars tyvar { UserTyVar $2 : $1 } + : tyvar tyvars { UserTyVar $1 : $2 } | {- empty -} { [] } fds :: { [([RdrName], [RdrName])] } @@ -732,9 +753,6 @@ forall :: { [RdrNameHsTyVar] } : 'forall' tyvars '.' { $2 } | {- empty -} { [] } -context :: { RdrNameContext } - : btype {% checkContext $1 } - constr_stuff :: { (RdrName, RdrNameConDetails) } : btype {% mkVanillaCon $1 [] } | btype '!' atype satypes {% mkVanillaCon $1 (BangType MarkedUserStrict $3 : $4) } @@ -1075,7 +1093,9 @@ deprec_var : var { $1 } | tycon { $1 } gtycon :: { RdrName } - : qtycon { $1 } + : tycon { $1 } + | qtycon { $1 } + | '(' tyconop ')' { $2 } | '(' qtyconop ')' { $2 } | '(' ')' { unitTyCon_RDR } | '(' '->' ')' { funTyCon_RDR } @@ -1183,7 +1203,7 @@ special_id ----------------------------------------------------------------------------- -- ConIds -qconid :: { RdrName } +qconid :: { RdrName } -- Qualified or unqualifiedb : conid { $1 } | QCONID { mkQual dataName $1 } @@ -1193,7 +1213,7 @@ conid :: { RdrName } ----------------------------------------------------------------------------- -- ConSyms -qconsym :: { RdrName } +qconsym :: { RdrName } -- Qualified or unqualifiedb : consym { $1 } | QCONSYM { mkQual dataName $1 } @@ -1270,13 +1290,11 @@ tycon :: { RdrName } tyconop :: { RdrName } : CONSYM { mkUnqual tcClsName $1 } -qtycon :: { RdrName } - : tycon { $1 } - | QCONID { mkQual tcClsName $1 } +qtycon :: { RdrName } -- Just the qualified kind + : QCONID { mkQual tcClsName $1 } -qtyconop :: { RdrName } - : tyconop { $1 } - | QCONSYM { mkQual tcClsName $1 } +qtyconop :: { RdrName } -- Just the qualified kind + : QCONSYM { mkQual tcClsName $1 } commas :: { Int } : commas ',' { $1 + 1 } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 5df53ae..c9bf3ad 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -192,7 +192,7 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. *** See "THE NAMING STORY" in HsDecls **** \begin{code} -mkClassDecl cxt cname tyvars fds sigs mbinds loc +mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds, tcdSysNames = new_names, tcdLoc = loc } @@ -213,12 +213,12 @@ mkClassDecl cxt cname tyvars fds sigs mbinds loc -- superclasses both called C!) new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names) -mkTyData new_or_data context tname list_var list_con i maybe src +mkTyData new_or_data (context, tname, tyvars) list_con i maybe src = let t_occ = rdrNameOcc tname name1 = mkRdrUnqual (mkGenOcc1 t_occ) name2 = mkRdrUnqual (mkGenOcc2 t_occ) in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname, - tcdTyVars = list_var, tcdCons = list_con, tcdNCons = i, + tcdTyVars = tyvars, tcdCons = list_con, tcdNCons = i, tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] } mkClassOpSigDM op ty loc -- 1.7.10.4