[project @ 1997-03-14 07:52:06 by simonpj]

[ghc-hetmet.git] / ghc / compiler / rename / ParseType.y

diff --git a/ghc/compiler/rename/ParseType.y b/ghc/compiler/rename/ParseType.y
new file mode 100644 (file)
index 0000000..d39c56b
--- /dev/null
+++ b/ghc/compiler/rename/ParseType.y
@@ -0,0 +1,140 @@
+{
+#include "HsVersions.h"
+module ParseType ( parseType ) where
+
+IMP_Ubiq(){-uitous-}
+
+import HsSyn           -- quite a bit of stuff
+import RdrHsSyn                -- oodles of synonyms
+import HsDecls         ( HsIdInfo(..) )
+import HsTypes         ( mkHsForAllTy )
+import HsCore
+import Literal
+import HsPragmas       ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas )
+import IdInfo          ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo,
+                         ArgUsageInfo, FBTypeInfo
+                       )
+import Kind            ( Kind, mkArrowKind, mkTypeKind )
+import Lex             
+
+import RnMonad         ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..),
+                         SYN_IE(RdrNamePragma), SYN_IE(ExportItem)
+                       ) 
+import Bag             ( emptyBag, unitBag, snocBag )
+import FiniteMap       ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
+import Name            ( OccName(..), isTCOcc, Provenance )
+import SrcLoc          ( mkIfaceSrcLoc )
+import Util            ( panic{-, pprPanic ToDo:rm-} )
+import Pretty           ( ppShow )
+import PprStyle         -- PprDebug for panic
+import Maybes           ( MaybeErr(..) )
+
+------------------------------------------------------------------
+
+parseType :: [IfaceToken] -> MaybeErr RdrNameHsType (PprStyle -> Int -> Bool -> PrettyRep)
+parseType ls =
+  let
+   res =
+    case parseT ls of
+      v@(Succeeded _) -> v
+      Failed err      -> panic (ppShow 80 (err PprDebug))
+  in
+  res
+
+}
+
+%name parseT
+%tokentype { IfaceToken }
+%monad     { IfM }{ thenIf }{ returnIf }
+
+%token
+       FORALL              { ITforall }
+       DCOLON              { ITdcolon }
+       COMMA               { ITcomma }
+       DARROW              { ITdarrow }
+       OCURLY              { ITocurly }
+       OBRACK              { ITobrack }
+       OPAREN              { IToparen }
+       RARROW              { ITrarrow }
+       CCURLY              { ITccurly }
+       CBRACK              { ITcbrack }
+       CPAREN              { ITcparen }
+
+       VARID               { ITvarid    $$ }
+       CONID               { ITconid    $$ }
+       VARSYM              { ITvarsym   $$ }
+       CONSYM              { ITconsym   $$ }
+       QCONID              { ITqconid   $$ }
+
+       UNKNOWN             { ITunknown $$ }
+%%
+
+type           :: { RdrNameHsType }
+type           : FORALL forall context DARROW type     { mkHsForAllTy $2 $3 $5 }
+               | tautype                               { $1 }
+
+forall         : OBRACK tv_bndrs CBRACK                { $2 }
+
+context                :: { RdrNameContext }
+context                :                                       { [] }
+               | OCURLY context_list1 CCURLY           { $2 }
+
+context_list1  :: { RdrNameContext }
+context_list1  : class                                 { [$1] }
+               | class COMMA context_list1             { $1 : $3 }
+
+class          :: { (RdrName, RdrNameHsType) }
+class          :  qtc_name atype                       { ($1, $2) }
+
+
+tautype                :: { RdrNameHsType }
+tautype                :  btype                                { $1 }
+               |  btype RARROW tautype                 { MonoFunTy $1 $3 }
+
+types2         :: { [RdrNameHsType]                    {- Two or more -}  }    
+types2         :  type COMMA type                      { [$1,$3] }
+               |  type COMMA types2                    { $1 : $3 }
+
+btype          :: { RdrNameHsType }
+btype          :  atype                                { $1 }
+               |  btype atype                          { MonoTyApp $1 $2 }
+
+atype          :: { RdrNameHsType }
+atype          :  qtc_name                             { MonoTyVar $1 }
+               |  tv_name                              { MonoTyVar $1 }
+               |  OPAREN types2 CPAREN                 { MonoTupleTy dummyRdrTcName $2 }
+               |  OBRACK type CBRACK                   { MonoListTy  dummyRdrTcName $2 }
+               |  OCURLY qtc_name atype CCURLY         { MonoDictTy $2 $3 }
+               |  OPAREN type CPAREN                   { $2 }
+
+atypes         :: { [RdrNameHsType]    {-  Zero or more -} }
+atypes         :                                       { [] }
+               |  atype atypes                         { $1 : $2
+---------------------------------------------------------------------
+                                                       }
+
+tv_bndr                :: { HsTyVar RdrName }
+tv_bndr                :  tv_name DCOLON akind { IfaceTyVar $1 $3 }
+               |  tv_name              { UserTyVar $1 }
+
+tv_bndrs       :: { [HsTyVar RdrName] }
+               :                       { [] }
+               | tv_bndr tv_bndrs      { $1 : $2 }
+
+kind           :: { Kind }
+               : akind                 { $1 }
+               | akind RARROW kind     { mkArrowKind $1 $3 }
+
+akind          :: { Kind }
+               : VARSYM                { mkTypeKind {- ToDo: check that it's "*" -} }
+               | OPAREN kind CPAREN    { $2 }
+
+tv_name                :: { RdrName }
+tv_name                :  VARID                { Unqual (TvOcc $1) }
+
+tv_names       :: { [RdrName] }
+               :                       { [] }
+               | tv_name tv_names      { $1 : $2 }
+qtc_name       :: { RdrName }
+qtc_name       :  QCONID               { tcQual $1 }
+