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

Parser changes to support type constructor operators; part of the generics stuff

diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index 2a733a7..5f929c6 100644 (file)
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -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

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 9f7ef43..7efc693 100644 (file)
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$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 }