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