ghc/compiler/rename/ParseType.y

   1 {
   2 #include "HsVersions.h"
   3 module ParseType ( parseType ) where
   4
   5 IMP_Ubiq(){-uitous-}
   6
   7 import HsSyn            -- quite a bit of stuff
   8 import RdrHsSyn         -- oodles of synonyms
   9 import HsDecls          ( HsIdInfo(..), HsStrictnessInfo )
  10 import HsTypes          ( mkHsForAllTy )
  11 import HsCore
  12 import Literal
  13 import HsPragmas        ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas )
  14 import IdInfo           ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo,
  15                           ArgUsageInfo, FBTypeInfo
  16                         )
  17 import Kind             ( Kind, mkArrowKind, mkBoxedTypeKind )
  18 import Lex
  19
  20 import RnMonad          ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..),
  21                           SYN_IE(RdrNamePragma), SYN_IE(ExportItem), GenAvailInfo
  22                         )
  23 import Bag              ( emptyBag, unitBag, snocBag )
  24 import FiniteMap        ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
  25 import Name             ( OccName(..), isTCOcc, Provenance )
  26 import SrcLoc           ( mkIfaceSrcLoc )
  27 import Util             ( panic{-, pprPanic ToDo:rm-} )
  28 import Pretty           ( Doc )
  29 import Outputable       ( PprStyle(..) )
  30 import Maybes           ( MaybeErr(..) )
  31
  32 ------------------------------------------------------------------
  33
  34 parseType :: StringBuffer -> MaybeErr RdrNameHsType (PprStyle -> Doc)
  35 parseType ls =
  36   let
  37    res =
  38     case parseT ls 1 of
  39       v@(Succeeded _) -> v
  40       Failed err      -> panic (show (err PprDebug))
  41   in
  42   res
  43
  44 }
  45
  46 %name parseT
  47 %tokentype { IfaceToken }
  48 %monad     { IfM }{ thenIf }{ returnIf }
  49 %lexer     { lexIface } { ITeof }
  50
  51 %token
  52         FORALL              { ITforall }
  53         DCOLON              { ITdcolon }
  54         COMMA               { ITcomma }
  55         DARROW              { ITdarrow }
  56         OCURLY              { ITocurly }
  57         OBRACK              { ITobrack }
  58         OPAREN              { IToparen }
  59         RARROW              { ITrarrow }
  60         CCURLY              { ITccurly }
  61         CBRACK              { ITcbrack }
  62         CPAREN              { ITcparen }
  63
  64         VARID               { ITvarid    $$ }
  65         CONID               { ITconid    $$ }
  66         VARSYM              { ITvarsym   $$ }
  67         CONSYM              { ITconsym   $$ }
  68         QCONID              { ITqconid   $$ }
  69         QCONSYM             { ITqconsym  $$ }
  70
  71         UNKNOWN             { ITunknown $$ }
  72 %%
  73
  74 type            :: { RdrNameHsType }
  75 type            : FORALL forall context DARROW type     { mkHsForAllTy $2 $3 $5 }
  76                 |  btype RARROW type                    { MonoFunTy $1 $3 }
  77                 |  btype                                { $1 }
  78
  79 forall          : OBRACK tv_bndrs CBRACK                { $2 }
  80
  81 context         :: { RdrNameContext }
  82 context         :                                       { [] }
  83                 | OCURLY context_list1 CCURLY           { $2 }
  84
  85 context_list1   :: { RdrNameContext }
  86 context_list1   : class                                 { [$1] }
  87                 | class COMMA context_list1             { $1 : $3 }
  88
  89 class           :: { (RdrName, RdrNameHsType) }
  90 class           :  tc_name atype                        { ($1, $2) }
  91
  92
  93 types2          :: { [RdrNameHsType]                    {- Two or more -}  }
  94 types2          :  type COMMA type                      { [$1,$3] }
  95                 |  type COMMA types2                    { $1 : $3 }
  96
  97 btype           :: { RdrNameHsType }
  98 btype           :  atype                                { $1 }
  99                 |  btype atype                          { MonoTyApp $1 $2 }
 100
 101 atype           :: { RdrNameHsType }
 102 atype           :  tc_name                              { MonoTyVar $1 }
 103                 |  tv_name                              { MonoTyVar $1 }
 104                 |  OPAREN types2 CPAREN                 { MonoTupleTy dummyRdrTcName $2 }
 105                 |  OBRACK type CBRACK                   { MonoListTy  dummyRdrTcName $2 }
 106                 |  OCURLY tc_name atype CCURLY          { MonoDictTy $2 $3 }
 107                 |  OPAREN type CPAREN                   { $2 }
 108
 109 atypes          :: { [RdrNameHsType]    {-  Zero or more -} }
 110 atypes          :                                       { [] }
 111                 |  atype atypes                         { $1 : $2
 112 ---------------------------------------------------------------------
 113                                                         }
 114
 115 tv_bndr         :: { HsTyVar RdrName }
 116 tv_bndr         :  tv_name DCOLON akind { IfaceTyVar $1 $3 }
 117                 |  tv_name              { UserTyVar $1 }
 118
 119 tv_bndrs        :: { [HsTyVar RdrName] }
 120                 :                       { [] }
 121                 | tv_bndr tv_bndrs      { $1 : $2 }
 122
 123 kind            :: { Kind }
 124                 : akind                 { $1 }
 125                 | akind RARROW kind     { mkArrowKind $1 $3 }
 126
 127 akind           :: { Kind }
 128                 : VARSYM                { mkBoxedTypeKind {- ToDo: check that it's "*" -} }
 129                 | OPAREN kind CPAREN    { $2 }
 130
 131 tv_name         :: { RdrName }
 132 tv_name         :  VARID                { Unqual (TvOcc $1) }
 133                 |  VARSYM               { Unqual (TvOcc $1) {- Allow t2 as a tyvar -} }
 134
 135 tv_names        :: { [RdrName] }
 136                 :                       { [] }
 137                 | tv_name tv_names      { $1 : $2 }
 138
 139 tc_name         :: { RdrName }
 140 tc_name         :  QCONID               { lexTcQual $1 }
 141                 |  QCONSYM              { lexTcQual $1 }
 142                 |  CONID                { Unqual (TCOcc $1) }
 143                 |  CONSYM               { Unqual (TCOcc $1) }
 144                 |  OPAREN RARROW CPAREN { Unqual (TCOcc SLIT("->")) }
 145