ghc/compiler/reader/ReadPrefix.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1998
   3 %
   4 \section{Read parse tree built by Yacc parser}
   5
   6 \begin{code}
   7 module ReadPrefix ( rdModule )  where
   8
   9 #include "HsVersions.h"
  10
  11 import UgenAll          -- all Yacc parser gumpff...
  12 import PrefixSyn        -- and various syntaxen.
  13 import HsSyn
  14 import HsTypes          ( HsTyVar(..) )
  15 import HsPragmas        ( noDataPragmas, noClassPragmas )
  16 import RdrHsSyn
  17 import BasicTypes       ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) )
  18 import PrefixToHs
  19 import CallConv
  20
  21 import CmdLineOpts      ( opt_NoImplicitPrelude, opt_GlasgowExts )
  22 import Name             ( OccName, srcTvOcc, srcVarOcc, srcTCOcc,
  23                           Module, mkModuleFS,
  24                           isConOcc, isLexConId
  25                         )
  26 import Outputable
  27 import SrcLoc           ( SrcLoc )
  28 import PrelMods         ( pRELUDE )
  29 import FastString       ( mkFastCharString )
  30 import PrelRead         ( readRational__ )
  31 \end{code}
  32
  33 %************************************************************************
  34 %*                                                                      *
  35 \subsection[ReadPrefix-help]{Help Functions}
  36 %*                                                                      *
  37 %************************************************************************
  38
  39 \begin{code}
  40 wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
  41
  42 wlkList wlk_it U_lnil = returnUgn []
  43
  44 wlkList wlk_it (U_lcons hd tl)
  45   = wlk_it  hd          `thenUgn` \ hd_it ->
  46     wlkList wlk_it tl   `thenUgn` \ tl_it ->
  47     returnUgn (hd_it : tl_it)
  48 \end{code}
  49
  50 \begin{code}
  51 wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
  52
  53 wlkMaybe wlk_it U_nothing  = returnUgn Nothing
  54 wlkMaybe wlk_it (U_just x)
  55   = wlk_it  x           `thenUgn` \ it ->
  56     returnUgn (Just it)
  57 \end{code}
  58
  59 \begin{code}
  60 wlkTCId   = wlkQid srcTCOcc
  61 wlkVarId  = wlkQid srcVarOcc
  62 wlkDataId = wlkQid srcVarOcc
  63 wlkEntId = wlkQid (\occ -> if isLexConId occ
  64                            then srcTCOcc occ
  65                            else srcVarOcc occ)
  66
  67 wlkQid  :: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName
  68
  69 -- There are three kinds of qid:
  70 --      qualified name (aqual)          A.x
  71 --      unqualified name (noqual)       x
  72 --      special name (gid)              [], (), ->, (,,,)
  73 -- The special names always mean "Prelude.whatever"; that's why
  74 -- they are distinct.  So if you write "()", it's just as if  you
  75 -- had written "Prelude.()".
  76 -- NB: The (qualified) prelude is always in scope, so the renamer will find it.
  77
  78 -- EXCEPT: when we're compiling with -fno-implicit-prelude, in which
  79 -- case we need to unqualify these things. -- SDM.
  80
  81 wlkQid mk_occ_name (U_noqual name)
  82   = returnUgn (Unqual (mk_occ_name name))
  83 wlkQid mk_occ_name (U_aqual  mod name)
  84   = returnUgn (Qual (mkModuleFS mod) (mk_occ_name name) HiFile)
  85 wlkQid mk_occ_name (U_gid n name)
  86   | opt_NoImplicitPrelude
  87         = returnUgn (Unqual (mk_occ_name name))
  88   | otherwise
  89         = returnUgn (Qual pRELUDE (mk_occ_name name) HiFile)
  90
  91
  92 rdTCId  pt = rdU_qid pt `thenUgn` wlkTCId
  93 rdVarId pt = rdU_qid pt `thenUgn` wlkVarId
  94
  95 rdTvId  pt = rdU_stringId pt `thenUgn` \ string -> wlkTvId string
  96 wlkTvId string = returnUgn (Unqual (srcTvOcc string))
  97
  98 cvFlag :: U_long -> Bool
  99 cvFlag 0 = False
 100 cvFlag 1 = True
 101 \end{code}
 102
 103 %************************************************************************
 104 %*                                                                      *
 105 \subsection[rdModule]{@rdModule@: reads in a Haskell module}
 106 %*                                                                      *
 107 %************************************************************************
 108
 109 \begin{code}
 110 rdModule :: IO (Module,             -- this module's name
 111                 RdrNameHsModule)    -- the main goods
 112
 113 rdModule
 114   = _ccall_ hspmain     >>= \ pt -> -- call the Yacc parser!
 115     let
 116         srcfile  = mkFastCharString ``input_filename'' -- What A Great Hack! (TM)
 117     in
 118     initUgn               $
 119     rdU_tree pt `thenUgn` \ (U_hmodule mod_fs himplist hexplist
 120                                        hmodlist srciface_version srcline) ->
 121     let
 122         mod_name = mkModuleFS mod_fs
 123     in
 124
 125     setSrcFileUgn srcfile               $
 126     setSrcModUgn  mod_name              $
 127     mkSrcLocUgn srcline                 $ \ src_loc     ->
 128
 129     wlkMaybe rdEntities hexplist `thenUgn` \ exports    ->
 130     wlkList  rdImport   himplist `thenUgn` \ imports    ->
 131     wlkBinding          hmodlist `thenUgn` \ binding    ->
 132
 133     let
 134         top_decls = cvTopDecls srcfile binding
 135     in
 136     returnUgn (mod_name,
 137                HsModule mod_name
 138                           (case srciface_version of { 0 -> Nothing; n -> Just n })
 139                           exports
 140                           imports
 141                           top_decls
 142                           src_loc
 143                 )
 144 \end{code}
 145
 146 %************************************************************************
 147 %*                                                                      *
 148 \subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
 149 %*                                                                      *
 150 %************************************************************************
 151
 152 \begin{code}
 153 rdExpr :: ParseTree -> UgnM RdrNameHsExpr
 154 rdPat  :: ParseTree -> UgnM RdrNamePat
 155
 156 rdExpr pt = rdU_tree pt `thenUgn` wlkExpr
 157 rdPat  pt = rdU_tree pt `thenUgn` wlkPat
 158
 159 wlkExpr :: U_tree -> UgnM RdrNameHsExpr
 160 wlkPat  :: U_tree -> UgnM RdrNamePat
 161
 162 wlkExpr expr
 163   = case expr of
 164       U_par pexpr -> -- parenthesised expr
 165         wlkExpr pexpr   `thenUgn` \ expr ->
 166         returnUgn (HsPar expr)
 167
 168       U_lsection lsexp lop -> -- left section
 169         wlkExpr lsexp   `thenUgn` \ expr ->
 170         wlkVarId  lop   `thenUgn` \ op   ->
 171         returnUgn (SectionL expr (HsVar op))
 172
 173       U_rsection rop rsexp -> -- right section
 174         wlkVarId  rop   `thenUgn` \ op   ->
 175         wlkExpr rsexp   `thenUgn` \ expr ->
 176         returnUgn (SectionR (HsVar op) expr)
 177
 178       U_ccall fun flavor ccargs -> -- ccall/casm
 179         wlkList rdExpr ccargs   `thenUgn` \ args ->
 180         let
 181             tag = _HEAD_ flavor
 182         in
 183         returnUgn (CCall fun args
 184                     (tag == 'p' || tag == 'P') -- may invoke GC
 185                     (tag == 'N' || tag == 'P') -- really a "casm"
 186                     (panic "CCall:result_ty"))
 187
 188       U_scc label sccexp -> -- scc (set-cost-centre) expression
 189         wlkExpr   sccexp        `thenUgn` \ expr  ->
 190         returnUgn (HsSCC label expr)
 191
 192       U_lambda match -> -- lambda expression
 193         wlkMatch match          `thenUgn` \ match' ->
 194         returnUgn (HsLam match')
 195
 196       U_casee caseexpr casebody srcline ->      -- case expression
 197         mkSrcLocUgn srcline              $ \ src_loc ->
 198         wlkExpr         caseexpr `thenUgn` \ expr ->
 199         wlkList rdMatch casebody `thenUgn` \ mats ->
 200         returnUgn (HsCase expr mats src_loc)
 201
 202       U_ife ifpred ifthen ifelse srcline ->     -- if expression
 203         mkSrcLocUgn srcline             $ \ src_loc ->
 204         wlkExpr ifpred          `thenUgn` \ e1 ->
 205         wlkExpr ifthen          `thenUgn` \ e2 ->
 206         wlkExpr ifelse          `thenUgn` \ e3 ->
 207         returnUgn (HsIf e1 e2 e3 src_loc)
 208
 209       U_let letvdefs letvexpr ->                -- let expression
 210         wlkLocalBinding letvdefs        `thenUgn` \ binding ->
 211         wlkExpr    letvexpr             `thenUgn` \ expr    ->
 212         returnUgn (HsLet binding expr)
 213
 214       U_doe gdo srcline ->                      -- do expression
 215         mkSrcLocUgn srcline             $ \ src_loc ->
 216         wlkList rd_stmt gdo     `thenUgn` \ stmts ->
 217         returnUgn (HsDo DoStmt stmts src_loc)
 218         where
 219         rd_stmt pt
 220           = rdU_tree pt `thenUgn` \ bind ->
 221             case bind of
 222               U_doexp exp srcline ->
 223                 mkSrcLocUgn srcline             $ \ src_loc ->
 224                 wlkExpr exp             `thenUgn` \ expr ->
 225                 returnUgn (ExprStmt expr src_loc)
 226
 227               U_dobind pat exp srcline ->
 228                 mkSrcLocUgn srcline             $ \ src_loc ->
 229                 wlkPat  pat             `thenUgn` \ patt ->
 230                 wlkExpr exp             `thenUgn` \ expr ->
 231                 returnUgn (BindStmt patt expr src_loc)
 232
 233               U_seqlet seqlet ->
 234                 wlkLocalBinding seqlet  `thenUgn` \ binds ->
 235                 returnUgn (LetStmt binds)
 236
 237       U_comprh cexp cquals -> -- list comprehension
 238         wlkExpr cexp            `thenUgn` \ expr  ->
 239         wlkQuals cquals         `thenUgn` \ quals ->
 240         getSrcLocUgn            `thenUgn` \ loc ->
 241         returnUgn (HsDo ListComp (quals ++ [ReturnStmt expr]) loc)
 242
 243       U_eenum efrom estep eto -> -- arithmetic sequence
 244         wlkExpr efrom           `thenUgn` \ e1  ->
 245         wlkMaybe rdExpr estep   `thenUgn` \ es2 ->
 246         wlkMaybe rdExpr eto     `thenUgn` \ es3 ->
 247         returnUgn (cv_arith_seq e1 es2 es3)
 248         where
 249            cv_arith_seq e1 Nothing   Nothing   = ArithSeqIn (From       e1)
 250            cv_arith_seq e1 Nothing   (Just e3) = ArithSeqIn (FromTo     e1 e3)
 251            cv_arith_seq e1 (Just e2) Nothing   = ArithSeqIn (FromThen   e1 e2)
 252            cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
 253
 254       U_restr restre restrt ->  -- expression with type signature
 255         wlkExpr     restre      `thenUgn` \ expr ->
 256         wlkHsSigType restrt     `thenUgn` \ ty   ->
 257         returnUgn (ExprWithTySig expr ty)
 258
 259       --------------------------------------------------------------
 260       -- now the prefix items that can either be an expression or
 261       -- pattern, except we know they are *expressions* here
 262       -- (this code could be commoned up with the pattern version;
 263       -- but it probably isn't worth it)
 264       --------------------------------------------------------------
 265       U_lit lit ->
 266         wlkLiteral lit  `thenUgn` \ lit ->
 267         returnUgn (HsLit lit)
 268
 269       U_ident n ->                      -- simple identifier
 270         wlkVarId n      `thenUgn` \ var ->
 271         returnUgn (HsVar var)
 272
 273       U_ap fun arg ->                   -- application
 274         wlkExpr fun     `thenUgn` \ expr1 ->
 275         wlkExpr arg     `thenUgn` \ expr2 ->
 276         returnUgn (HsApp expr1 expr2)
 277
 278       U_infixap fun arg1 arg2 ->        -- infix application
 279         wlkVarId  fun   `thenUgn` \ op    ->
 280         wlkExpr arg1    `thenUgn` \ expr1 ->
 281         wlkExpr arg2    `thenUgn` \ expr2 ->
 282         returnUgn (mkOpApp expr1 op expr2)
 283
 284       U_negate nexp ->                  -- prefix negation
 285         wlkExpr nexp    `thenUgn` \ expr ->
 286         returnUgn (NegApp expr (HsVar dummyRdrVarName))
 287
 288       U_llist llist -> -- explicit list
 289         wlkList rdExpr llist `thenUgn` \ exprs ->
 290         returnUgn (ExplicitList exprs)
 291
 292       U_tuple tuplelist -> -- explicit tuple
 293         wlkList rdExpr tuplelist `thenUgn` \ exprs ->
 294         returnUgn (ExplicitTuple exprs True)
 295
 296       U_utuple tuplelist -> -- explicit tuple
 297         wlkList rdExpr tuplelist `thenUgn` \ exprs ->
 298         returnUgn (ExplicitTuple exprs False)
 299
 300       U_record con rbinds -> -- record construction
 301         wlkDataId  con          `thenUgn` \ rcon     ->
 302         wlkList rdRbind rbinds  `thenUgn` \ recbinds ->
 303         returnUgn (RecordCon rcon recbinds)
 304
 305       U_rupdate updexp updbinds -> -- record update
 306         wlkExpr updexp           `thenUgn` \ aexp ->
 307         wlkList rdRbind updbinds `thenUgn` \ recbinds ->
 308         returnUgn (RecordUpd aexp recbinds)
 309
 310 #ifdef DEBUG
 311       U_hmodule _ _ _ _ _ _   -> error "U_hmodule"
 312       U_as _ _                -> error "U_as"
 313       U_lazyp _               -> error "U_lazyp"
 314       U_wildp                 -> error "U_wildp"
 315       U_qual _ _              -> error "U_qual"
 316       U_guard _               -> error "U_guard"
 317       U_seqlet _              -> error "U_seqlet"
 318       U_dobind _ _ _          -> error "U_dobind"
 319       U_doexp _ _             -> error "U_doexp"
 320       U_rbind _ _             -> error "U_rbind"
 321 #endif
 322
 323 rdRbind pt
 324   = rdU_tree pt         `thenUgn` \ (U_rbind var exp) ->
 325     wlkVarId   var      `thenUgn` \ rvar ->
 326     wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
 327     returnUgn (
 328       case expr_maybe of
 329         Nothing -> (rvar, HsVar rvar, True{-pun-})
 330         Just re -> (rvar, re,         False)
 331     )
 332
 333 wlkQuals cquals
 334   = wlkList rd_qual cquals
 335   where
 336           rd_qual pt
 337             = rdU_tree pt       `thenUgn` \ qual ->
 338               wlk_qual qual
 339
 340           wlk_qual qual
 341             = case qual of
 342                 U_guard exp ->
 343                   wlkExpr exp   `thenUgn` \ expr ->
 344                   getSrcLocUgn  `thenUgn` \ loc ->
 345                   returnUgn (GuardStmt expr loc)
 346
 347                 U_qual qpat qexp ->
 348                   wlkPat  qpat  `thenUgn` \ pat  ->
 349                   wlkExpr qexp  `thenUgn` \ expr ->
 350                   getSrcLocUgn  `thenUgn` \ loc ->
 351                   returnUgn (BindStmt pat expr loc)
 352
 353                 U_seqlet seqlet ->
 354                   wlkLocalBinding seqlet        `thenUgn` \ binds ->
 355                   returnUgn (LetStmt binds)
 356
 357                 U_let letvdefs letvexpr ->
 358                     wlkLocalBinding letvdefs    `thenUgn` \ binds ->
 359                     wlkExpr    letvexpr         `thenUgn` \ expr    ->
 360                     getSrcLocUgn                `thenUgn` \ loc ->
 361                     returnUgn (GuardStmt (HsLet binds expr) loc)
 362 \end{code}
 363
 364 Patterns: just bear in mind that lists of patterns are represented as
 365 a series of ``applications''.
 366 \begin{code}
 367 wlkPat pat
 368   = case pat of
 369       U_par ppat ->                     -- parenthesised pattern
 370         wlkPat ppat     `thenUgn` \ pat ->
 371         -- tidy things up a little:
 372         returnUgn (
 373         case pat of
 374           VarPatIn _ -> pat
 375           WildPatIn  -> pat
 376           other      -> ParPatIn pat
 377         )
 378
 379       U_as avar as_pat ->               -- "as" pattern
 380         wlkVarId avar   `thenUgn` \ var ->
 381         wlkPat as_pat   `thenUgn` \ pat ->
 382         returnUgn (AsPatIn var pat)
 383
 384       U_restr pat ty ->
 385         wlkPat pat      `thenUgn` \ pat' ->
 386         wlkHsType ty    `thenUgn` \ ty' ->
 387         returnUgn (SigPatIn pat' ty')
 388
 389       U_lazyp lazyp ->                  -- irrefutable ("twiddle") pattern
 390         wlkPat lazyp    `thenUgn` \ pat ->
 391         returnUgn (LazyPatIn pat)
 392
 393       U_plusp avar lit ->
 394         wlkVarId avar   `thenUgn` \ var ->
 395         wlkLiteral lit  `thenUgn` \ lit ->
 396         returnUgn (NPlusKPatIn var lit)
 397
 398       U_wildp -> returnUgn WildPatIn    -- wildcard pattern
 399
 400       U_lit lit ->                      -- literal pattern
 401         wlkLiteral lit  `thenUgn` \ lit ->
 402         returnUgn (LitPatIn lit)
 403
 404       U_ident nn ->                     -- simple identifier
 405         wlkVarId nn     `thenUgn` \ n ->
 406         returnUgn (
 407           if isConOcc (rdrNameOcc n) then
 408                 ConPatIn n []
 409           else
 410                 VarPatIn n
 411         )
 412
 413       U_ap l r ->       -- "application": there's a list of patterns lurking here!
 414         wlkPat r                `thenUgn` \ rpat         ->
 415         collect_pats l [rpat]   `thenUgn` \ (lpat,lpats) ->
 416         (case lpat of
 417             VarPatIn x          -> returnUgn (x,  lpats)
 418             ConPatIn x []       -> returnUgn (x,  lpats)
 419             ConOpPatIn x op _ y -> returnUgn (op, x:y:lpats)
 420             _ -> getSrcLocUgn   `thenUgn` \ loc ->
 421                  pprPanic "Illegal pattern `application'"
 422                           (ppr loc <> colon <+> hsep (map ppr (lpat:lpats)))
 423
 424         )                       `thenUgn` \ (n, arg_pats) ->
 425         returnUgn (ConPatIn n arg_pats)
 426         where
 427           collect_pats pat acc
 428             = case pat of
 429                 U_ap l r ->
 430                   wlkPat r      `thenUgn` \ rpat  ->
 431                   collect_pats l (rpat:acc)
 432                 other ->
 433                   wlkPat other  `thenUgn` \ pat ->
 434                   returnUgn (pat,acc)
 435
 436       U_infixap fun arg1 arg2 ->        -- infix pattern
 437         wlkVarId fun    `thenUgn` \ op   ->
 438         wlkPat arg1     `thenUgn` \ pat1 ->
 439         wlkPat arg2     `thenUgn` \ pat2 ->
 440         returnUgn (ConOpPatIn pat1 op (error "ConOpPatIn:fixity") pat2)
 441
 442       U_negate npat ->                  -- negated pattern
 443         wlkPat npat     `thenUgn` \ pat ->
 444         returnUgn (NegPatIn pat)
 445
 446       U_llist llist ->                  -- explicit list
 447         wlkList rdPat llist     `thenUgn` \ pats ->
 448         returnUgn (ListPatIn pats)
 449
 450       U_tuple tuplelist ->              -- explicit tuple
 451         wlkList rdPat tuplelist `thenUgn` \ pats ->
 452         returnUgn (TuplePatIn pats True)
 453
 454       U_utuple tuplelist ->             -- explicit tuple
 455         wlkList rdPat tuplelist `thenUgn` \ pats ->
 456         returnUgn (TuplePatIn pats False)
 457
 458       U_record con rpats ->             -- record destruction
 459         wlkDataId  con          `thenUgn` \ rcon     ->
 460         wlkList rdRpat rpats    `thenUgn` \ recpats ->
 461         returnUgn (RecPatIn rcon recpats)
 462         where
 463           rdRpat pt
 464             = rdU_tree pt        `thenUgn` \ (U_rbind var pat) ->
 465               wlkVarId   var     `thenUgn` \ rvar ->
 466               wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
 467               returnUgn (
 468                 case pat_maybe of
 469                   Nothing -> (rvar, VarPatIn rvar, True{-pun-})
 470                   Just rp -> (rvar, rp,            False)
 471               )
 472 \end{code}
 473
 474 \begin{code}
 475 wlkLiteral :: U_literal -> UgnM HsLit
 476
 477 wlkLiteral ulit
 478   = returnUgn (
 479     case ulit of
 480       U_integer    s -> HsInt        (as_integer  s)
 481       U_floatr     s -> HsFrac       (as_rational s)
 482       U_intprim    s -> HsIntPrim    (as_integer  s)
 483       U_doubleprim s -> HsDoublePrim (as_rational s)
 484       U_floatprim  s -> HsFloatPrim  (as_rational s)
 485       U_charr      s -> HsChar       (as_char     s)
 486       U_charprim   s -> HsCharPrim   (as_char     s)
 487       U_string     s -> HsString     (as_string   s)
 488       U_stringprim s -> HsStringPrim (as_string   s)
 489       U_clitlit    s -> HsLitLit     (as_string   s)
 490     )
 491   where
 492     as_char s     = _HEAD_ s
 493     as_integer s  = readInteger (_UNPK_ s)
 494     as_rational s = readRational__ (_UNPK_ s) -- use non-std readRational__
 495                                               -- to handle rationals with leading '-'
 496     as_string s   = s
 497 \end{code}
 498
 499 %************************************************************************
 500 %*                                                                      *
 501 \subsection{wlkBinding}
 502 %*                                                                      *
 503 %************************************************************************
 504
 505 \begin{code}
 506 wlkLocalBinding bind
 507   = wlkBinding bind     `thenUgn` \ bind' ->
 508     getSrcFileUgn       `thenUgn` \ sf    ->
 509     returnUgn (cvBinds sf cvValSig bind')
 510
 511 wlkBinding :: U_binding -> UgnM RdrBinding
 512
 513 wlkBinding binding
 514   = case binding of
 515         -- null binding
 516       U_nullbind ->
 517         returnUgn RdrNullBind
 518
 519         -- "and" binding (just glue, really)
 520       U_abind a b ->
 521         wlkBinding a    `thenUgn` \ binding1 ->
 522         wlkBinding b    `thenUgn` \ binding2 ->
 523         returnUgn (RdrAndBindings binding1 binding2)
 524
 525         -- fixity declaration
 526       U_fixd op dir_n prec srcline ->
 527         let
 528               dir = case dir_n of
 529                         (-1) -> InfixL
 530                         0    -> InfixN
 531                         1    -> InfixR
 532         in
 533         wlkVarId op             `thenUgn` \ op ->
 534         mkSrcLocUgn srcline     $ \ src_loc ->
 535         returnUgn (RdrSig (FixSig (FixitySig op (Fixity prec dir) src_loc)))
 536
 537
 538         -- "data" declaration
 539       U_tbind tctxt ttype tcons tderivs srcline ->
 540         mkSrcLocUgn        srcline          $ \ src_loc     ->
 541         wlkContext         tctxt    `thenUgn` \ ctxt        ->
 542         wlkConAndTyVars    ttype    `thenUgn` \ (tycon, tyvars) ->
 543         wlkList rdConDecl  tcons    `thenUgn` \ cons        ->
 544         wlkDerivings       tderivs  `thenUgn` \ derivings   ->
 545         returnUgn (RdrTyClDecl (TyData DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
 546
 547         -- "newtype" declaration
 548       U_ntbind ntctxt nttype ntcon ntderivs srcline ->
 549         mkSrcLocUgn        srcline          $ \ src_loc     ->
 550         wlkContext         ntctxt   `thenUgn` \ ctxt        ->
 551         wlkConAndTyVars    nttype   `thenUgn` \ (tycon, tyvars) ->
 552         wlkList rdConDecl  ntcon    `thenUgn` \ cons        ->
 553         wlkDerivings       ntderivs `thenUgn` \ derivings   ->
 554         returnUgn (RdrTyClDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
 555
 556         -- "type" declaration
 557       U_nbind nbindid nbindas srcline ->
 558         mkSrcLocUgn       srcline         $ \ src_loc       ->
 559         wlkConAndTyVars   nbindid `thenUgn` \ (tycon, tyvars) ->
 560         wlkHsType         nbindas `thenUgn` \ expansion     ->
 561         returnUgn (RdrTyClDecl (TySynonym tycon tyvars expansion src_loc))
 562
 563         -- function binding
 564       U_fbind fbindm srcline ->
 565         mkSrcLocUgn     srcline         $ \ src_loc ->
 566         wlkList rdMatch fbindm          `thenUgn` \ matches ->
 567         returnUgn (RdrValBinding (mkRdrFunctionBinding matches src_loc))
 568
 569         -- pattern binding
 570       U_pbind pbindl pbindr srcline ->
 571         mkSrcLocUgn srcline             $ \ src_loc ->
 572         rdPat pbindl                    `thenUgn` \ pat ->
 573         rdGRHSs pbindr                  `thenUgn` \ grhss ->
 574         returnUgn (RdrValBinding (PatMonoBind pat grhss src_loc))
 575
 576         -- "class" declaration
 577       U_cbind cbindc cbindid cbindw srcline ->
 578         mkSrcLocUgn      srcline        $ \ src_loc         ->
 579         wlkContext       cbindc  `thenUgn` \ ctxt           ->
 580         wlkConAndTyVars  cbindid `thenUgn` \ (clas, tyvars) ->
 581         wlkBinding       cbindw  `thenUgn` \ binding        ->
 582         getSrcFileUgn            `thenUgn` \ sf             ->
 583         let
 584             (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
 585         in
 586         returnUgn (RdrTyClDecl
 587           (mkClassDecl ctxt clas tyvars final_sigs final_methods noClassPragmas src_loc))
 588
 589         -- "instance" declaration
 590       U_ibind ty ibindw srcline ->
 591         -- The "ty" contains the instance context too
 592         -- So for "instance Eq a => Eq [a]" the type will be
 593         --      Eq a => Eq [a]
 594         mkSrcLocUgn     srcline         $ \ src_loc ->
 595         wlkInstType       ty            `thenUgn` \ inst_ty    ->
 596         wlkBinding      ibindw          `thenUgn` \ binding ->
 597         getSrcModUgn                    `thenUgn` \ modname ->
 598         getSrcFileUgn                   `thenUgn` \ sf      ->
 599         let
 600             (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
 601         in
 602         returnUgn (RdrInstDecl
 603           (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc))
 604
 605         -- "default" declaration
 606       U_dbind dbindts srcline ->
 607         mkSrcLocUgn        srcline      $ \ src_loc ->
 608         wlkList rdMonoType dbindts  `thenUgn` \ tys ->
 609         returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
 610
 611         -- "foreign" declaration
 612       U_fobind id ty ext_name unsafe_flag cconv imp_exp srcline ->
 613         mkSrcLocUgn        srcline                 $ \ src_loc ->
 614         wlkVarId id                                `thenUgn` \ h_id ->
 615         wlkHsType ty                               `thenUgn` \ h_ty ->
 616         wlkExtName ext_name                        `thenUgn` \ h_ext_name ->
 617         rdCallConv cconv                           `thenUgn` \ h_cconv ->
 618         rdForKind imp_exp (cvFlag unsafe_flag)    `thenUgn` \ h_imp_exp ->
 619         returnUgn (RdrForeignDecl (ForeignDecl h_id h_imp_exp h_ty h_ext_name h_cconv src_loc))
 620
 621       U_sbind sbindids sbindid srcline ->
 622         -- Type signature
 623         mkSrcLocUgn srcline             $ \ src_loc ->
 624         wlkList rdVarId sbindids        `thenUgn` \ vars    ->
 625         wlkHsSigType    sbindid         `thenUgn` \ poly_ty ->
 626         returnUgn (foldr1 RdrAndBindings [RdrSig (Sig var poly_ty src_loc) | var <- vars])
 627
 628       U_vspec_uprag uvar vspec_tys srcline ->
 629         -- value specialisation user-pragma
 630         mkSrcLocUgn srcline             $ \ src_loc ->
 631         wlkVarId uvar                   `thenUgn` \ var ->
 632         wlkList rd_ty_and_id vspec_tys  `thenUgn` \ tys_and_ids ->
 633         returnUgn (foldr1 RdrAndBindings [ RdrSig (SpecSig var ty using_id src_loc)
 634                                          | (ty, using_id) <- tys_and_ids ])
 635         where
 636           rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
 637           rd_ty_and_id pt
 638               = rdU_binding pt                  `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
 639                 wlkHsSigType vspec_ty           `thenUgn` \ ty       ->
 640                 wlkMaybe rdVarId vspec_id       `thenUgn` \ id_maybe ->
 641                 returnUgn(ty, id_maybe)
 642
 643       U_ispec_uprag iclas ispec_ty srcline ->
 644         -- instance specialisation user-pragma
 645         mkSrcLocUgn srcline             $ \ src_loc ->
 646         wlkHsSigType ispec_ty           `thenUgn` \ ty      ->
 647         returnUgn (RdrSig (SpecInstSig ty src_loc))
 648
 649       U_inline_uprag ivar srcline ->
 650         -- value inlining user-pragma
 651         mkSrcLocUgn     srcline         $ \ src_loc ->
 652         wlkVarId        ivar            `thenUgn` \ var     ->
 653         returnUgn (RdrSig (InlineSig var src_loc))
 654
 655       U_noinline_uprag ivar srcline ->
 656         -- No-inline pragma
 657         mkSrcLocUgn     srcline         $ \ src_loc ->
 658         wlkVarId        ivar            `thenUgn` \ var     ->
 659         returnUgn (RdrSig (NoInlineSig var src_loc))
 660
 661
 662 mkRdrFunctionBinding :: [RdrNameMatch] -> SrcLoc -> RdrNameMonoBinds
 663 mkRdrFunctionBinding fun_matches src_loc
 664   = FunMonoBind (head fns) (head infs) matches src_loc
 665   where
 666     (fns, infs, matches) = unzip3 (map de_fun_match fun_matches)
 667
 668     de_fun_match (Match _ [ConPatIn fn pats]      sig grhss) = (fn, False, Match [] pats    sig grhss)
 669     de_fun_match (Match _ [ConOpPatIn p1 fn _ p2] sig grhss) = (fn, True,  Match [] [p1,p2] sig grhss)
 670
 671
 672 rdGRHSs :: ParseTree -> UgnM RdrNameGRHSs
 673 rdGRHSs pt = rdU_grhsb pt `thenUgn` wlkGRHSs
 674
 675 wlkGRHSs :: U_grhsb -> UgnM RdrNameGRHSs
 676 wlkGRHSs (U_pguards rhss bind)
 677   = wlkList rdGdExp rhss        `thenUgn` \ gdexps ->
 678     wlkLocalBinding bind        `thenUgn` \ bind' ->
 679     returnUgn (GRHSs gdexps bind' Nothing)
 680 wlkGRHSs (U_pnoguards srcline rhs bind)
 681   = mkSrcLocUgn srcline         $ \ src_loc ->
 682     rdExpr rhs                  `thenUgn` \ rhs' ->
 683     wlkLocalBinding bind        `thenUgn` \ bind' ->
 684     returnUgn (GRHSs (unguardedRHS rhs' src_loc) bind' Nothing)
 685
 686
 687 rdGdExp :: ParseTree -> UgnM RdrNameGRHS
 688 rdGdExp pt = rdU_gdexp pt               `thenUgn` \ (U_pgdexp guards srcline rhs) ->
 689              wlkQuals guards            `thenUgn` \ guards' ->
 690              mkSrcLocUgn srcline        $ \ src_loc ->
 691              wlkExpr rhs                `thenUgn` \ expr'  ->
 692              returnUgn (GRHS (guards' ++ [ExprStmt expr' src_loc]) src_loc)
 693 \end{code}
 694
 695 \begin{code}
 696 wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName])
 697
 698 wlkDerivings (U_nothing) = returnUgn Nothing
 699 wlkDerivings (U_just pt)
 700   = rdU_list pt          `thenUgn` \ ds     ->
 701     wlkList rdTCId ds    `thenUgn` \ derivs ->
 702     returnUgn (Just derivs)
 703 \end{code}
 704
 705 %************************************************************************
 706 %*                                                                      *
 707 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
 708 %*                                                                      *
 709 %************************************************************************
 710
 711 \begin{code}
 712 rdHsType :: ParseTree -> UgnM RdrNameHsType
 713 rdMonoType :: ParseTree -> UgnM RdrNameHsType
 714
 715 rdHsType   pt = rdU_ttype pt `thenUgn` wlkHsType
 716 rdMonoType pt = rdU_ttype pt `thenUgn` wlkHsType
 717
 718 wlkHsConstrArgType ttype
 719         -- Used for the argument types of contructors
 720         -- Only an implicit quantification point if -fglasgow-exts
 721   | opt_GlasgowExts = wlkHsSigType ttype
 722   | otherwise       = wlkHsType    ttype
 723
 724         -- wlkHsSigType is used for type signatures: any place there
 725         -- should be *implicit* quantification
 726 wlkHsSigType ttype
 727   = wlkHsType ttype     `thenUgn` \ ty ->
 728         -- This is an implicit quantification point, so
 729         -- make sure it starts with a ForAll
 730     case ty of
 731         HsForAllTy _ _ _ -> returnUgn ty
 732         other            -> returnUgn (HsForAllTy [] [] ty)
 733
 734 wlkHsType :: U_ttype -> UgnM RdrNameHsType
 735 wlkHsType ttype
 736   = case ttype of
 737       U_forall u_tyvars u_theta u_ty -> -- context
 738         wlkList rdTvId u_tyvars         `thenUgn` \ tyvars ->
 739         wlkContext u_theta              `thenUgn` \ theta ->
 740         wlkHsType u_ty                  `thenUgn` \ ty   ->
 741         returnUgn (HsForAllTy (map UserTyVar tyvars) theta ty)
 742
 743       U_namedtvar tv -> -- type variable
 744         wlkTvId tv      `thenUgn` \ tyvar ->
 745         returnUgn (MonoTyVar tyvar)
 746
 747       U_tname tcon -> -- type constructor
 748         wlkTCId tcon    `thenUgn` \ tycon ->
 749         returnUgn (MonoTyVar tycon)
 750
 751       U_tapp t1 t2 ->
 752         wlkHsType t1            `thenUgn` \ ty1 ->
 753         wlkHsType t2            `thenUgn` \ ty2 ->
 754         returnUgn (MonoTyApp ty1 ty2)
 755
 756       U_tllist tlist -> -- list type
 757         wlkHsType tlist `thenUgn` \ ty ->
 758         returnUgn (MonoListTy ty)
 759
 760       U_ttuple ttuple ->
 761         wlkList rdMonoType ttuple `thenUgn` \ tys ->
 762         returnUgn (MonoTupleTy tys True)
 763
 764       U_tutuple ttuple ->
 765         wlkList rdMonoType ttuple `thenUgn` \ tys ->
 766         returnUgn (MonoTupleTy tys False)
 767
 768       U_tfun tfun targ ->
 769         wlkHsType tfun  `thenUgn` \ ty1 ->
 770         wlkHsType targ  `thenUgn` \ ty2 ->
 771         returnUgn (MonoFunTy ty1 ty2)
 772
 773 wlkInstType ttype
 774   = case ttype of
 775       U_forall u_tyvars u_theta inst_head ->
 776         wlkList rdTvId u_tyvars         `thenUgn` \ tyvars ->
 777         wlkContext  u_theta             `thenUgn` \ theta ->
 778         wlkConAndTys inst_head          `thenUgn` \ (clas, tys)  ->
 779         returnUgn (HsForAllTy (map UserTyVar tyvars) theta (MonoDictTy clas tys))
 780
 781       other -> -- something else
 782         wlkConAndTys other   `thenUgn` \ (clas, tys) ->
 783         returnUgn (HsForAllTy [] [] (MonoDictTy clas tys))
 784 \end{code}
 785
 786 \begin{code}
 787 wlkConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
 788 wlkConAndTyVars ttype
 789   = wlkHsType ttype     `thenUgn` \ ty ->
 790     let
 791         split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args)
 792         split (MonoTyVar tycon)               args = (tycon,args)
 793         split other                           args = pprPanic "ERROR: malformed type: "
 794                                                      (ppr other)
 795     in
 796     returnUgn (split ty [])
 797
 798
 799 wlkContext   :: U_list  -> UgnM RdrNameContext
 800 rdConAndTys  :: ParseTree -> UgnM (RdrName, [HsType RdrName])
 801
 802 wlkContext list = wlkList rdConAndTys list
 803
 804 rdConAndTys pt = rdU_ttype pt `thenUgn` wlkConAndTys
 805
 806 wlkConAndTys ttype
 807   = wlkHsType ttype     `thenUgn` \ ty ->
 808     let
 809         split (MonoTyApp fun ty) tys = split fun (ty : tys)
 810         split (MonoTyVar tycon)  tys = (tycon, tys)
 811         split other              tys = pprPanic "ERROR: malformed type: "
 812                                              (ppr other)
 813     in
 814     returnUgn (split ty [])
 815 \end{code}
 816
 817 \begin{code}
 818 rdConDecl :: ParseTree -> UgnM RdrNameConDecl
 819 rdConDecl pt = rdU_constr pt    `thenUgn` wlkConDecl
 820
 821 wlkConDecl :: U_constr -> UgnM RdrNameConDecl
 822
 823 wlkConDecl (U_constrex u_tvs ccxt ccdecl)
 824   = wlkList rdTvId u_tvs        `thenUgn` \ tyvars ->
 825     wlkContext ccxt             `thenUgn` \ theta ->
 826     wlkConDecl ccdecl           `thenUgn` \ (ConDecl con _ _ details loc) ->
 827     returnUgn (ConDecl con (map UserTyVar tyvars) theta details loc)
 828
 829 wlkConDecl (U_constrpre ccon ctys srcline)
 830   = mkSrcLocUgn srcline                 $ \ src_loc ->
 831     wlkDataId   ccon            `thenUgn` \ con     ->
 832     wlkList     rdBangType ctys `thenUgn` \ tys     ->
 833     returnUgn (ConDecl con [] [] (VanillaCon tys) src_loc)
 834
 835 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
 836   = mkSrcLocUgn srcline                 $ \ src_loc ->
 837     wlkBangType cty1            `thenUgn` \ ty1     ->
 838     wlkDataId   cop             `thenUgn` \ op      ->
 839     wlkBangType cty2            `thenUgn` \ ty2     ->
 840     returnUgn (ConDecl op [] [] (InfixCon ty1 ty2) src_loc)
 841
 842 wlkConDecl (U_constrnew ccon cty srcline)
 843   = mkSrcLocUgn srcline                 $ \ src_loc ->
 844     wlkDataId   ccon            `thenUgn` \ con     ->
 845     wlkHsSigType cty            `thenUgn` \ ty      ->
 846     returnUgn (ConDecl con [] [] (NewCon ty) src_loc)
 847
 848 wlkConDecl (U_constrrec ccon cfields srcline)
 849   = mkSrcLocUgn srcline                 $ \ src_loc      ->
 850     wlkDataId   ccon            `thenUgn` \ con          ->
 851     wlkList rd_field cfields    `thenUgn` \ fields_lists ->
 852     returnUgn (ConDecl con [] [] (RecCon fields_lists) src_loc)
 853   where
 854     rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
 855     rd_field pt
 856       = rdU_constr pt           `thenUgn` \ (U_field fvars fty) ->
 857         wlkList rdVarId fvars   `thenUgn` \ vars ->
 858         wlkBangType fty         `thenUgn` \ ty ->
 859         returnUgn (vars, ty)
 860
 861 -----------------
 862 rdBangType pt = rdU_ttype pt `thenUgn` wlkBangType
 863
 864 wlkBangType :: U_ttype -> UgnM (BangType RdrName)
 865
 866 wlkBangType (U_tbang bty) = wlkHsConstrArgType bty      `thenUgn` \ ty ->
 867                             returnUgn (Banged   ty)
 868 wlkBangType uty           = wlkHsConstrArgType uty      `thenUgn` \ ty ->
 869                             returnUgn (Unbanged ty)
 870 \end{code}
 871
 872 %************************************************************************
 873 %*                                                                      *
 874 \subsection{Read a ``match''}
 875 %*                                                                      *
 876 %************************************************************************
 877
 878 \begin{code}
 879 rdMatch :: ParseTree -> UgnM RdrNameMatch
 880 rdMatch pt = rdU_match pt `thenUgn` wlkMatch
 881
 882 wlkMatch :: U_match -> UgnM RdrNameMatch
 883 wlkMatch (U_pmatch pats sig grhsb)
 884   = wlkList rdPat pats          `thenUgn` \ pats'   ->
 885     wlkMaybe rdHsType sig       `thenUgn` \ maybe_ty ->
 886     wlkGRHSs grhsb              `thenUgn` \ grhss' ->
 887     returnUgn (Match [] pats' maybe_ty grhss')
 888 \end{code}
 889
 890 %************************************************************************
 891 %*                                                                      *
 892 \subsection[rdImport]{Read an import decl}
 893 %*                                                                      *
 894 %************************************************************************
 895
 896 \begin{code}
 897 rdImport :: ParseTree
 898          -> UgnM RdrNameImportDecl
 899
 900 rdImport pt
 901   = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec isrc srcline) ->
 902     mkSrcLocUgn srcline                         $ \ src_loc      ->
 903     wlkMaybe rdU_stringId ias           `thenUgn` \ maybe_as    ->
 904     wlkMaybe rd_spec ispec              `thenUgn` \ maybe_spec  ->
 905     returnUgn (ImportDecl (mkModuleFS imod)
 906                           (cvFlag iqual)
 907                           (cvIfaceFlavour isrc)
 908                           (case maybe_as of { Just m -> Just (mkModuleFS m); Nothing -> Nothing })
 909                           maybe_spec src_loc)
 910   where
 911     rd_spec pt = rdU_either pt          `thenUgn` \ spec ->
 912       case spec of
 913         U_left pt  -> rdEntities pt     `thenUgn` \ ents ->
 914                       returnUgn (False, ents)
 915         U_right pt -> rdEntities pt     `thenUgn` \ ents ->
 916                       returnUgn (True, ents)
 917
 918 cvIfaceFlavour 0 = HiFile       -- No pragam
 919 cvIfaceFlavour 1 = HiBootFile   -- {-# SOURCE #-}
 920 \end{code}
 921
 922 \begin{code}
 923 rdEntities pt = rdU_list pt `thenUgn` wlkList rdEntity
 924
 925 rdEntity :: ParseTree -> UgnM (IE RdrName)
 926
 927 rdEntity pt
 928   = rdU_entidt pt `thenUgn` \ entity ->
 929     case entity of
 930       U_entid evar ->           -- just a value
 931         wlkEntId        evar            `thenUgn` \ var ->
 932         returnUgn (IEVar var)
 933
 934       U_enttype x ->            -- abstract type constructor/class
 935         wlkTCId x               `thenUgn` \ thing ->
 936         returnUgn (IEThingAbs thing)
 937
 938       U_enttypeall x ->         -- non-abstract type constructor/class
 939         wlkTCId x               `thenUgn` \ thing ->
 940         returnUgn (IEThingAll thing)
 941
 942       U_enttypenamed x ns ->    -- non-abstract type constructor/class
 943                                 -- with specified constrs/methods
 944         wlkTCId x               `thenUgn` \ thing ->
 945         wlkList rdVarId ns      `thenUgn` \ names ->
 946         returnUgn (IEThingWith thing names)
 947
 948       U_entmod mod ->           -- everything provided unqualified by a module
 949         returnUgn (IEModuleContents (mkModuleFS mod))
 950 \end{code}
 951
 952
 953 %************************************************************************
 954 %*                                                                      *
 955 \subsection[rdExtName]{Read an external name}
 956 %*                                                                      *
 957 %************************************************************************
 958
 959 \begin{code}
 960 wlkExtName :: U_maybe -> UgnM ExtName
 961 wlkExtName (U_nothing) = returnUgn Dynamic
 962 wlkExtName (U_just pt)
 963   = rdU_list pt             `thenUgn` \ ds ->
 964     wlkList rdU_hstring ds  `thenUgn` \ ss ->
 965     case ss of
 966       [nm]     -> returnUgn (ExtName nm Nothing)
 967       [mod,nm] -> returnUgn (ExtName nm (Just mod))
 968
 969 rdCallConv :: Int -> UgnM CallConv
 970 rdCallConv x =
 971    -- this tracks the #defines in parser/utils.h
 972   case x of
 973     (-1) -> -- no calling convention specified, use default.
 974           returnUgn defaultCallConv
 975     _    -> returnUgn x
 976
 977 rdForKind :: Int -> Bool -> UgnM ForKind
 978 rdForKind 0 isUnsafe = -- foreign import
 979   returnUgn (FoImport isUnsafe)
 980 rdForKind 1 _ = -- foreign export
 981   returnUgn FoExport
 982 rdForKind 2 _ = -- foreign label
 983   returnUgn FoLabel
 984
 985 \end{code}