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