Commit 54c848ff authored by simonpj's avatar simonpj
Browse files

[project @ 2000-10-05 15:42:30 by simonpj]

Parser changes to support type constructor operators; part of the generics stuff
parent 07f46536
......@@ -7,8 +7,7 @@
module ParseUtil (
parseError -- String -> Pa
, cbot -- a
, splitForConApp -- RdrNameHsType -> [RdrNameBangType]
-- -> P (RdrName, [RdrNameBangType])
, mkVanillaCon, mkRecCon,
, mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
, groupBindings
......@@ -36,7 +35,7 @@ import RdrHsSyn ( mkNPlusKPatIn, unitTyCon_RDR,
RdrBinding(..),
RdrNameHsType, RdrNameBangType, RdrNameContext,
RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs,
RdrNameHsRecordBinds, RdrNameMonoBinds
RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails
)
import RdrName
import CallConv
......@@ -57,40 +56,37 @@ parseError s =
cbot = panic "CCall:result_ty"
-----------------------------------------------------------------------------
-- splitForConApp
-- mkVanillaCon
-- When parsing data declarations, we sometimes inadvertently parse
-- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
-- This function splits up the type application, adds any pending
-- arguments, and converts the type constructor back into a data constructor.
splitForConApp :: RdrNameHsType -> [RdrNameBangType]
-> P (RdrName, [RdrNameBangType])
mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
splitForConApp t ts = split t ts
mkVanillaCon ty tys
= split ty tys
where
split (HsAppTy t u) ts = split t (Unbanged u : ts)
{- split (HsOpTy t1 t ty2) ts =
-- check that we've got a type constructor at the head
if occNameSpace t_occ /= tcClsName
then parseError
(showSDoc (text "not a constructor: (type pattern)`" <>
ppr t <> char '\''))
else returnP (con, ts)
where t_occ = rdrNameOcc t
con = setRdrNameOcc t (setOccNameSpace t_occ dataName)
-}
split (HsTyVar t) ts =
-- check that we've got a type constructor at the head
if occNameSpace t_occ /= tcClsName
then parseError
(showSDoc (text "not a constructor: `" <>
ppr t <> char '\''))
else returnP (con, ts)
where t_occ = rdrNameOcc t
con = setRdrNameOcc t (setOccNameSpace t_occ dataName)
split _ _ = parseError "Illegal data/newtype declaration"
split (HsAppTy t u) ts = split t (Unbanged u : ts)
split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con ->
returnP (data_con, VanillaCon ts)
split _ _ = parseError "Illegal data/newtype declaration"
mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
mkRecCon con fields
= tyConToDataCon con `thenP` \ data_con ->
returnP (data_con, RecCon fields)
tyConToDataCon :: RdrName -> P RdrName
tyConToDataCon tc
| occNameSpace tc_occ == tcClsName
= returnP (setRdrNameOcc tc (setOccNameSpace tc_occ dataName))
| otherwise
= parseError (showSDoc (text "not a constructor:" <+> quotes (ppr tc)))
where
tc_occ = rdrNameOcc tc
----------------------------------------------------------------------------
-- Various Syntactic Checks
......
{-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.37 2000/10/03 08:43:02 simonpj Exp $
$Id: Parser.y,v 1.38 2000/10/05 15:42:30 simonpj Exp $
Haskell grammar.
......@@ -570,6 +570,11 @@ varids0 :: { [RdrName] }
-----------------------------------------------------------------------------
-- Datatype declarations
newconstr :: { RdrNameConDecl }
: srcloc conid atype { mkConDecl $2 [] [] (VanillaCon [Unbanged $3]) $1 }
| srcloc conid '{' var '::' type '}'
{ mkConDecl $2 [] [] (RecCon [([$4], Unbanged $6)]) $1 }
constrs :: { [RdrNameConDecl] }
: constrs '|' constr { $3 : $1 }
| constr { [$1] }
......@@ -588,27 +593,14 @@ context :: { RdrNameContext }
: btype '=>' {% checkContext $1 }
constr_stuff :: { (RdrName, RdrNameConDetails) }
: scontype { (fst $1, VanillaCon (snd $1)) }
: btype {% mkVanillaCon $1 [] }
| btype '!' atype satypes {% mkVanillaCon $1 (Banged $3 : $4) }
| gtycon '{' fielddecls '}' {% mkRecCon $1 $3 }
| sbtype conop sbtype { ($2, InfixCon $1 $3) }
| con '{' fielddecls '}' { ($1, RecCon (reverse $3)) }
newconstr :: { RdrNameConDecl }
: srcloc conid atype { mkConDecl $2 [] [] (VanillaCon [Unbanged $3]) $1 }
| srcloc conid '{' var '::' type '}'
{ mkConDecl $2 [] [] (RecCon [([$4], Unbanged $6)]) $1 }
scontype :: { (RdrName, [RdrNameBangType]) }
: btype {% splitForConApp $1 [] }
| scontype1 { $1 }
scontype1 :: { (RdrName, [RdrNameBangType]) }
: btype '!' atype {% splitForConApp $1 [Banged $3] }
| scontype1 satype { (fst $1, snd $1 ++ [$2] ) }
| '(' consym ')' { ($2,[]) }
satype :: { RdrNameBangType }
: atype { Unbanged $1 }
| '!' atype { Banged $2 }
satypes :: { [RdrNameBangType] }
: atype satypes { Unbanged $1 : $2 }
| '!' atype satypes { Banged $2 : $3 }
sbtype :: { RdrNameBangType }
: btype { Unbanged $1 }
......@@ -885,6 +877,7 @@ dbind : ipvar '=' exp { ($1, $3) }
gtycon :: { RdrName }
: qtycon { $1 }
| '(' qtyconop ')' { $2 }
| '(' ')' { unitTyCon_RDR }
| '(' '->' ')' { funTyCon_RDR }
| '[' ']' { listTyCon_RDR }
......@@ -911,10 +904,6 @@ qvar :: { RdrName }
ipvar :: { RdrName }
: IPVARID { (mkSrcUnqual ipName (tailFS $1)) }
con :: { RdrName }
: conid { $1 }
| '(' consym ')' { $2 }
qcon :: { RdrName }
: qconid { $1 }
| '(' qconsym ')' { $2 }
......@@ -1078,6 +1067,10 @@ qtycon :: { RdrName }
: tycon { $1 }
| QCONID { mkSrcQual tcClsName $1 }
qtyconop :: { RdrName }
: tyconop { $1 }
| QCONSYM { mkSrcQual tcClsName $1 }
qtycls :: { RdrName }
: qtycon { $1 }
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment