summaryrefslogtreecommitdiff
path: root/compiler/parser
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/parser')
-rw-r--r--compiler/parser/Parser.y.pp85
-rw-r--r--compiler/parser/ParserCore.y12
-rw-r--r--compiler/parser/RdrHsSyn.lhs142
3 files changed, 189 insertions, 50 deletions
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 4e98c24df9..da0082567c 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -45,6 +45,17 @@ import GLAEXTS
{-
-----------------------------------------------------------------------------
+26 July 2006
+
+Conflicts: 37 shift/reduce
+ 1 reduce/reduce
+
+The reduce/reduce conflict is weird. It's between tyconsym and consym, and I
+would think the two should never occur in the same context.
+
+ -=chak
+
+-----------------------------------------------------------------------------
Conflicts: 36 shift/reduce (1.25)
10 for abiguity in 'if x then y else z + 1' [State 178]
@@ -430,10 +441,12 @@ topdecls :: { OrdList (LHsDecl RdrName) }
| topdecl { $1 }
topdecl :: { OrdList (LHsDecl RdrName) }
- : tycl_decl { unitOL (L1 (TyClD (unLoc $1))) }
+ : cl_decl { unitOL (L1 (TyClD (unLoc $1))) }
+ | ty_decl {% checkTopTyClD $1 >>= return.unitOL.L1 }
| 'instance' inst_type where
- { let (binds,sigs) = cvBindsAndSigs (unLoc $3)
- in unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs))) }
+ { let (binds, sigs, ats) = cvBindsAndSigs (unLoc $3)
+ in unitOL (L (comb3 $1 $2 $3)
+ (InstD (InstDecl $2 binds sigs ats))) }
| 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) }
| 'foreign' fdecl { unitOL (LL (unLoc $2)) }
| '{-# DEPRECATED' deprecations '#-}' { $2 }
@@ -446,7 +459,21 @@ topdecl :: { OrdList (LHsDecl RdrName) }
L1 $ HsVar (mkUnqual varName (getTH_ID_SPLICE $1))
)) }
-tycl_decl :: { LTyClDecl RdrName }
+-- Type classes
+--
+cl_decl :: { LTyClDecl RdrName }
+ : 'class' tycl_hdr fds where
+ {% do { let { (binds, sigs, ats) =
+ cvBindsAndSigs (unLoc $4)
+ ; (ctxt, tc, tvs, Just tparms) = unLoc $2}
+ ; checkTyVars tparms
+ ; return $ L (comb4 $1 $2 $3 $4)
+ (mkClassDecl (ctxt, tc, tvs)
+ (unLoc $3) sigs binds ats) } }
+
+-- Type declarations
+--
+ty_decl :: { LTyClDecl RdrName }
: 'type' type '=' ctype
-- Note type on the left of the '='; this allows
-- infix type constructors to be declared
@@ -469,13 +496,6 @@ tycl_decl :: { LTyClDecl RdrName }
{ L (comb4 $1 $2 $4 $5)
(mkTyData (unLoc $1) (unLoc $2) $3 (reverse (unLoc $5)) (unLoc $6)) }
- | 'class' tycl_hdr fds where
- { let
- (binds,sigs) = cvBindsAndSigs (unLoc $4)
- in
- L (comb4 $1 $2 $3 $4) (mkClassDecl (unLoc $2) (unLoc $3) sigs
- binds) }
-
data_or_newtype :: { Located NewOrData }
: 'data' { L1 DataType }
| 'newtype' { L1 NewType }
@@ -484,19 +504,49 @@ opt_kind_sig :: { Maybe Kind }
: { Nothing }
| '::' kind { Just $2 }
--- tycl_hdr parses the header of a type or class decl,
+-- tycl_hdr parses the header of a type decl,
-- which takes the form
-- T a b
-- Eq a => T a
-- (Eq a, Ord b) => T a b
+-- T Int [a] -- for associated types
-- Rather a lot of inlining here, else we get reduce/reduce errors
-tycl_hdr :: { Located (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) }
+tycl_hdr :: { Located (LHsContext RdrName,
+ Located RdrName,
+ [LHsTyVarBndr RdrName],
+ Maybe [LHsType RdrName]) }
: context '=>' type {% checkTyClHdr $1 $3 >>= return.LL }
| type {% checkTyClHdr (noLoc []) $1 >>= return.L1 }
-----------------------------------------------------------------------------
-- Nested declarations
+-- Type declaration or value declaration
+--
+tydecl :: { Located (OrdList (LHsDecl RdrName)) }
+tydecl : ty_decl { LL (unitOL (L1 (TyClD (unLoc $1)))) }
+ | decl { $1 }
+
+tydecls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
+ : tydecls ';' tydecl { LL (unLoc $1 `appOL` unLoc $3) }
+ | tydecls ';' { LL (unLoc $1) }
+ | tydecl { $1 }
+ | {- empty -} { noLoc nilOL }
+
+
+tydecllist
+ :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
+ : '{' tydecls '}' { LL (unLoc $2) }
+ | vocurly tydecls close { $2 }
+
+-- Form of the body of class and instance declarations
+--
+where :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
+ -- No implicit parameters
+ -- May have type declarations
+ : 'where' tydecllist { LL (unLoc $2) }
+ | {- empty -} { noLoc nilOL }
+
decls :: { Located (OrdList (LHsDecl RdrName)) }
: decls ';' decl { LL (unLoc $1 `appOL` unLoc $3) }
| decls ';' { LL (unLoc $1) }
@@ -508,17 +558,16 @@ decllist :: { Located (OrdList (LHsDecl RdrName)) }
: '{' decls '}' { LL (unLoc $2) }
| vocurly decls close { $2 }
-where :: { Located (OrdList (LHsDecl RdrName)) }
- -- No implicit parameters
- : 'where' decllist { LL (unLoc $2) }
- | {- empty -} { noLoc nilOL }
-
+-- Binding groups other than those of class and instance declarations
+--
binds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters
+ -- No type declarations
: decllist { L1 (HsValBinds (cvBindGroup (unLoc $1))) }
| '{' dbinds '}' { LL (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
| vocurly dbinds close { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
wherebinds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters
+ -- No type declarations
: 'where' binds { LL (unLoc $2) }
| {- empty -} { noLoc emptyLocalBinds }
diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index b24ec2e9d7..a6ee5ddc89 100644
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -88,10 +88,18 @@ tdefs :: { [TyClDecl RdrName] }
tdef :: { TyClDecl RdrName }
: '%data' q_tc_name tv_bndrs '=' '{' cons '}'
- { mkTyData DataType (noLoc [], noLoc (ifaceExtRdrName $2), map toHsTvBndr $3) Nothing $6 Nothing }
+ { mkTyData DataType ( noLoc []
+ , noLoc (ifaceExtRdrName $2)
+ , map toHsTvBndr $3
+ , Nothing
+ ) Nothing $6 Nothing }
| '%newtype' q_tc_name tv_bndrs trep
{ let tc_rdr = ifaceExtRdrName $2 in
- mkTyData NewType (noLoc [], noLoc tc_rdr, map toHsTvBndr $3) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
+ mkTyData NewType ( noLoc []
+ , noLoc tc_rdr
+ , map toHsTvBndr $3
+ , Nothing
+ ) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
-- For a newtype we have to invent a fake data constructor name
-- It doesn't matter what it is, because it won't be used
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index ca24070a04..777ff64d8c 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -8,7 +8,7 @@ module RdrHsSyn (
extractHsTyRdrTyVars,
extractHsRhoRdrTyVars, extractGenericPatTyVars,
- mkHsOpApp, mkClassDecl,
+ mkHsOpApp, mkClassDecl,
mkHsNegApp, mkHsIntegral, mkHsFractional,
mkHsDo, mkHsSplice,
mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
@@ -36,7 +36,9 @@ module RdrHsSyn (
checkContext, -- HsType -> P HsContext
checkPred, -- HsType -> P HsPred
checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
+ checkTyVars, -- [LHsType RdrName] -> P ()
checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
+ checkTopTyClD, -- LTyClDecl RdrName -> P (HsDecl RdrName)
checkInstType, -- HsType -> P HsType
checkPattern, -- HsExp -> P HsPat
checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
@@ -155,12 +157,13 @@ mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
= ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
tcdFDs = fds,
tcdSigs = sigs,
- tcdMeths = mbinds
+ tcdMeths = mbinds,
+ tcdATs = ats
}
-mkTyData new_or_data (context, tname, tyvars) ksig data_cons maybe_deriv
+mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
= TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
- tcdTyVars = tyvars, tcdCons = data_cons,
+ tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
tcdKindSig = ksig, tcdDerivs = maybe_deriv }
\end{code}
@@ -198,23 +201,29 @@ cvTopDecls decls = go (fromOL decls)
where (L l' b', ds') = getMonoBind (L l b) ds
go (d : ds) = d : go ds
+-- Declaration list may only contain value bindings and signatures
+--
cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
cvBindGroup binding
- = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
- ValBindsIn mbs sigs
- }
+ = case cvBindsAndSigs binding of
+ (mbs, sigs, []) -> -- list of type decls *always* empty
+ ValBindsIn mbs sigs
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
- -> (Bag (LHsBind RdrName), [LSig RdrName])
+ -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName])
-- Input decls contain just value bindings and signatures
+-- and in case of class or instance declarations also
+-- associated data or synonym definitions
cvBindsAndSigs fb = go (fromOL fb)
where
- go [] = (emptyBag, [])
- go (L l (SigD s) : ds) = (bs, L l s : ss)
- where (bs,ss) = go ds
- go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
- where (b',ds') = getMonoBind (L l b) ds
- (bs,ss) = go ds'
+ go [] = (emptyBag, [], [])
+ go (L l (SigD s) : ds) = (bs, L l s : ss, ts)
+ where (bs, ss, ts) = go ds
+ go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts)
+ where (b', ds') = getMonoBind (L l b) ds
+ (bs, ss, ts) = go ds'
+ go (L l (TyClD t): ds) = (bs, ss, L l t : ts)
+ where (bs, ss, ts) = go ds
-----------------------------------------------------------------------------
-- Group function bindings into equation groups
@@ -368,44 +377,61 @@ checkInstType (L l t)
ty -> do dict_ty <- checkDictTy (L l ty)
return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
-checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
-checkTyVars tvs
- = mapM chk tvs
+-- Check that the given list of type parameters are all type variables
+-- (possibly with a kind signature).
+--
+checkTyVars :: [LHsType RdrName] -> P ()
+checkTyVars tvs = mapM_ chk tvs
where
- -- Check that the name space is correct!
+ -- Check that the name space is correct!
chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
- | isRdrTyVar tv = return (L l (KindedTyVar tv k))
+ | isRdrTyVar tv = return ()
chk (L l (HsTyVar tv))
- | isRdrTyVar tv = return (L l (UserTyVar tv))
+ | isRdrTyVar tv = return ()
chk (L l other)
= parseError l "Type found where type variable expected"
checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
-checkSynHdr ty = do { (_, tc, tvs) <- checkTyClHdr (noLoc []) ty
+checkSynHdr ty = do { (_, tc, tvs, Just tparms) <- checkTyClHdr (noLoc []) ty
+ ; checkTyVars tparms
; return (tc, tvs) }
checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
- -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
+ -> P (LHsContext RdrName, -- the type context
+ Located RdrName, -- the head symbol (type or class name)
+ [LHsTyVarBndr RdrName], -- free variables of the non-context part
+ Maybe [LHsType RdrName]) -- parameters of head symbol; wrapped into
+ -- 'Maybe' for 'mkTyData'
-- The header of a type or class decl should look like
-- (C a, D b) => T a b
-- or T a b
-- or a + b
-- etc
+-- With associated types, we can also have non-variable parameters; ie,
+-- T Int [a]
+-- The unaltered parameter list is returned in the fourth component of the
+-- result. Eg, for
+-- T Int [a]
+-- we return
+-- ('()', 'T', ['a'], Just ['Int', '[a]'])
checkTyClHdr (L l cxt) ty
- = do (tc, tvs) <- gol ty []
+ = do (tc, tvs, parms) <- gol ty []
mapM_ chk_pred cxt
- return (L l cxt, tc, tvs)
+ return (L l cxt, tc, tvs, Just parms)
where
gol (L l ty) acc = go l ty acc
go l (HsTyVar tc) acc
- | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs ->
- return (L l tc, tvs)
- go l (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs ->
- return (tc, tvs)
+ | not (isRdrTyVar tc) = do
+ tvs <- extractTyVars acc
+ return (L l tc, tvs, acc)
+ go l (HsOpTy t1 tc t2) acc = do
+ tvs <- extractTyVars (t1:t2:acc)
+ return (tc, tvs, acc)
go l (HsParTy ty) acc = gol ty acc
go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
- go l other acc = parseError l "Malformed LHS to type of class declaration"
+ go l other acc =
+ parseError l "Malformed head of type or class declaration"
-- The predicates in a type or class decl must all
-- be HsClassPs. They need not all be type variables,
@@ -414,7 +440,63 @@ checkTyClHdr (L l cxt) ty
chk_pred (L l _)
= parseError l "Malformed context in type or class declaration"
-
+-- Extract the type variables of a list of type parameters.
+--
+-- * Type arguments can be complex type terms (needed for associated type
+-- declarations).
+--
+extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
+extractTyVars tvs = collects [] tvs
+ where
+ -- Collect all variables (1st arg serves as an accumulator)
+ collect tvs (L l (HsForAllTy _ _ _ _)) =
+ parseError l "Forall type not allowed as type parameter"
+ collect tvs (L l (HsTyVar tv))
+ | isRdrTyVar tv = return $ L l (UserTyVar tv) : tvs
+ | otherwise = return tvs
+ collect tvs (L l (HsBangTy _ _ )) =
+ parseError l "Bang-style type annotations not allowed as type parameter"
+ collect tvs (L l (HsAppTy t1 t2 )) = do
+ tvs' <- collect tvs t2
+ collect tvs' t1
+ collect tvs (L l (HsFunTy t1 t2 )) = do
+ tvs' <- collect tvs t2
+ collect tvs' t1
+ collect tvs (L l (HsListTy t )) = collect tvs t
+ collect tvs (L l (HsPArrTy t )) = collect tvs t
+ collect tvs (L l (HsTupleTy _ ts )) = collects tvs ts
+ collect tvs (L l (HsOpTy t1 _ t2 )) = do
+ tvs' <- collect tvs t2
+ collect tvs' t1
+ collect tvs (L l (HsParTy t )) = collect tvs t
+ collect tvs (L l (HsNumTy t )) = return tvs
+ collect tvs (L l (HsPredTy t )) =
+ parseError l "Predicate not allowed as type parameter"
+ collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
+ | isRdrTyVar tv =
+ return $ L l (KindedTyVar tv k) : tvs
+ | otherwise =
+ parseError l "Kind signature only allowed for type variables"
+ collect tvs (L l (HsSpliceTy t )) =
+ parseError l "Splice not allowed as type parameter"
+
+ -- Collect all variables of a list of types
+ collects tvs [] = return tvs
+ collects tvs (t:ts) = do
+ tvs' <- collects tvs ts
+ collect tvs' t
+
+-- Wrap a toplevel type or class declaration into 'TyClDecl' after ensuring
+-- that all type parameters are variables only (which is in contrast to
+-- associated type declarations).
+--
+checkTopTyClD :: LTyClDecl RdrName -> P (HsDecl RdrName)
+checkTopTyClD (L _ d@TyData {tcdTyPats = Just typats}) =
+ do
+ checkTyVars typats
+ return $ TyClD d {tcdTyPats = Nothing}
+checkTopTyClD (L _ d) = return $ TyClD d
+
checkContext :: LHsType RdrName -> P (LHsContext RdrName)
checkContext (L l t)
= check t
View Lorry Controller Status