ghc/compiler/reader/ReadPrefix.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   3 %
   4 \section{Read parse tree built by Yacc parser}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module ReadPrefix ( rdModule )  where
  10
  11 IMP_Ubiq()
  12 IMPORT_1_3(IO(hPutStr, stderr))
  13 #if __GLASGOW_HASKELL__ == 201
  14 import GHCio(stThen)
  15 #elif __GLASGOW_HASKELL__ >= 202
  16 import GlaExts
  17 import IOBase
  18 import PrelRead
  19 #endif
  20
  21 import UgenAll          -- all Yacc parser gumpff...
  22 import PrefixSyn        -- and various syntaxen.
  23 import HsSyn
  24 import HsTypes          ( HsTyVar(..) )
  25 import HsPragmas        ( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas )
  26 import RdrHsSyn
  27 import BasicTypes       ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) )
  28 import PrefixToHs
  29
  30 import CmdLineOpts      ( opt_PprUserLength )
  31 import ErrUtils         ( addErrLoc, ghcExit )
  32 import FiniteMap        ( elemFM, FiniteMap )
  33 import Name             ( OccName(..), SYN_IE(Module) )
  34 import Lex              ( isLexConId )
  35 import Outputable       ( Outputable(..), PprStyle(..) )
  36 import PrelMods
  37 import Pretty
  38 import SrcLoc           ( mkGeneratedSrcLoc, noSrcLoc, SrcLoc )
  39 import Util             ( nOfThem, pprError, panic )
  40 \end{code}
  41
  42 %************************************************************************
  43 %*                                                                      *
  44 \subsection[ReadPrefix-help]{Help Functions}
  45 %*                                                                      *
  46 %************************************************************************
  47
  48 \begin{code}
  49 wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
  50
  51 wlkList wlk_it U_lnil = returnUgn []
  52
  53 wlkList wlk_it (U_lcons hd tl)
  54   = wlk_it  hd          `thenUgn` \ hd_it ->
  55     wlkList wlk_it tl   `thenUgn` \ tl_it ->
  56     returnUgn (hd_it : tl_it)
  57 \end{code}
  58
  59 \begin{code}
  60 wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
  61
  62 wlkMaybe wlk_it U_nothing  = returnUgn Nothing
  63 wlkMaybe wlk_it (U_just x)
  64   = wlk_it  x           `thenUgn` \ it ->
  65     returnUgn (Just it)
  66 \end{code}
  67
  68 \begin{code}
  69 wlkTvId   = wlkQid TvOcc
  70 wlkTCId   = wlkQid TCOcc
  71 wlkVarId  = wlkQid VarOcc
  72 wlkDataId = wlkQid VarOcc
  73 wlkEntId = wlkQid (\occ -> if isLexConId occ
  74                            then TCOcc occ
  75                            else VarOcc occ)
  76
  77 wlkQid  :: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName
  78 wlkQid mk_occ_name (U_noqual name)
  79   = returnUgn (Unqual (mk_occ_name name))
  80 wlkQid mk_occ_name (U_aqual  mod name)
  81   = returnUgn (Qual mod (mk_occ_name name) HiFile)
  82
  83         -- I don't understand this one!  It is what shows up when we meet (), [], or (,,,).
  84 wlkQid mk_occ_name (U_gid n name)
  85   = returnUgn (Unqual (mk_occ_name name))
  86
  87 rdTCId  pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid
  88 rdVarId pt = rdU_qid pt `thenUgn` \ qid -> wlkVarId qid
  89
  90 cvFlag :: U_long -> Bool
  91 cvFlag 0 = False
  92 cvFlag 1 = True
  93 \end{code}
  94
  95 %************************************************************************
  96 %*                                                                      *
  97 \subsection[rdModule]{@rdModule@: reads in a Haskell module}
  98 %*                                                                      *
  99 %************************************************************************
 100
 101 \begin{code}
 102 #if __GLASGOW_HASKELL__ == 201
 103 # define PACK_STR packCString
 104 #elif __GLASGOW_HASKELL__ >= 202
 105 # define PACK_STR mkFastCharString
 106 #else
 107 # define PACK_STR mkFastCharString
 108 #endif
 109
 110 rdModule :: IO (Module,             -- this module's name
 111                 RdrNameHsModule)    -- the main goods
 112
 113 rdModule
 114   = _ccall_ hspmain `CCALL_THEN` \ pt -> -- call the Yacc parser!
 115     let
 116         srcfile  = PACK_STR ``input_filename'' -- What A Great Hack! (TM)
 117     in
 118     initUgn               $
 119     rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist
 120                                        hmodlist srciface_version srcline) ->
 121
 122     setSrcFileUgn srcfile $
 123     setSrcModUgn  modname $
 124     mkSrcLocUgn srcline   $                \ src_loc    ->
 125
 126     wlkMaybe rdEntities hexplist `thenUgn` \ exports    ->
 127     wlkList  rdImport   himplist `thenUgn` \ imports    ->
 128     wlkList  rdFixOp    hfixlist `thenUgn` \ fixities   ->
 129     wlkBinding          hmodlist `thenUgn` \ binding    ->
 130
 131     let
 132         val_decl    = ValD (cvBinds srcfile cvValSig binding)
 133         other_decls = cvOtherDecls binding
 134     in
 135     returnUgn (modname,
 136                HsModule modname
 137                           (case srciface_version of { 0 -> Nothing; n -> Just n })
 138                           exports
 139                           imports
 140                           fixities
 141                           (val_decl: other_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` \ tree -> wlkExpr tree
 157 rdPat  pt = rdU_tree pt `thenUgn` \ tree -> wlkPat  tree
 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 lampats lamexpr srcline -> -- lambda expression
 193         mkSrcLocUgn   srcline           $ \ src_loc ->
 194         wlkList rdPat lampats   `thenUgn` \ pats ->
 195         wlkExpr       lamexpr   `thenUgn` \ body ->
 196         returnUgn (
 197             HsLam (foldr PatMatch
 198                          (GRHSMatch (GRHSsAndBindsIn
 199                                       [OtherwiseGRHS body src_loc]
 200                                       EmptyBinds))
 201                          pats)
 202         )
 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         getSrcFileUgn            `thenUgn` \ sf ->
 209         let
 210             matches = cvMatches sf True mats
 211         in
 212         returnUgn (HsCase expr matches src_loc)
 213
 214       U_ife ifpred ifthen ifelse srcline ->     -- if expression
 215         mkSrcLocUgn srcline             $ \ src_loc ->
 216         wlkExpr ifpred          `thenUgn` \ e1 ->
 217         wlkExpr ifthen          `thenUgn` \ e2 ->
 218         wlkExpr ifelse          `thenUgn` \ e3 ->
 219         returnUgn (HsIf e1 e2 e3 src_loc)
 220
 221       U_let letvdefs letvexpr ->                -- let expression
 222         wlkBinding letvdefs     `thenUgn` \ binding ->
 223         wlkExpr    letvexpr     `thenUgn` \ expr    ->
 224         getSrcFileUgn           `thenUgn` \ sf      ->
 225         let
 226             binds = cvBinds sf cvValSig binding
 227         in
 228         returnUgn (HsLet binds expr)
 229
 230       U_doe gdo srcline ->                      -- do expression
 231         mkSrcLocUgn srcline             $ \ src_loc ->
 232         wlkList rd_stmt gdo     `thenUgn` \ stmts ->
 233         returnUgn (HsDo DoStmt stmts src_loc)
 234         where
 235         rd_stmt pt
 236           = rdU_tree pt `thenUgn` \ bind ->
 237             case bind of
 238               U_doexp exp srcline ->
 239                 mkSrcLocUgn srcline             $ \ src_loc ->
 240                 wlkExpr exp             `thenUgn` \ expr ->
 241                 returnUgn (ExprStmt expr src_loc)
 242
 243               U_dobind pat exp srcline ->
 244                 mkSrcLocUgn srcline             $ \ src_loc ->
 245                 wlkPat  pat             `thenUgn` \ patt ->
 246                 wlkExpr exp             `thenUgn` \ expr ->
 247                 returnUgn (BindStmt patt expr src_loc)
 248
 249               U_seqlet seqlet ->
 250                 wlkBinding seqlet       `thenUgn` \ bs ->
 251                 getSrcFileUgn           `thenUgn` \ sf ->
 252                 let
 253                     binds = cvBinds sf cvValSig bs
 254                 in
 255                 returnUgn (LetStmt binds)
 256
 257       U_comprh cexp cquals -> -- list comprehension
 258         wlkExpr cexp            `thenUgn` \ expr  ->
 259         wlkQuals cquals         `thenUgn` \ quals ->
 260         getSrcLocUgn            `thenUgn` \ loc ->
 261         returnUgn (HsDo ListComp (quals ++ [ReturnStmt expr]) loc)
 262
 263       U_eenum efrom estep eto -> -- arithmetic sequence
 264         wlkExpr efrom           `thenUgn` \ e1  ->
 265         wlkMaybe rdExpr estep   `thenUgn` \ es2 ->
 266         wlkMaybe rdExpr eto     `thenUgn` \ es3 ->
 267         returnUgn (cv_arith_seq e1 es2 es3)
 268         where
 269            cv_arith_seq e1 Nothing   Nothing   = ArithSeqIn (From       e1)
 270            cv_arith_seq e1 Nothing   (Just e3) = ArithSeqIn (FromTo     e1 e3)
 271            cv_arith_seq e1 (Just e2) Nothing   = ArithSeqIn (FromThen   e1 e2)
 272            cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
 273
 274       U_restr restre restrt ->  -- expression with type signature
 275         wlkExpr     restre      `thenUgn` \ expr ->
 276         wlkHsType restrt        `thenUgn` \ ty   ->
 277         returnUgn (ExprWithTySig expr ty)
 278
 279       --------------------------------------------------------------
 280       -- now the prefix items that can either be an expression or
 281       -- pattern, except we know they are *expressions* here
 282       -- (this code could be commoned up with the pattern version;
 283       -- but it probably isn't worth it)
 284       --------------------------------------------------------------
 285       U_lit lit ->
 286         wlkLiteral lit  `thenUgn` \ lit ->
 287         returnUgn (HsLit lit)
 288
 289       U_ident n ->                      -- simple identifier
 290         wlkVarId n      `thenUgn` \ var ->
 291         returnUgn (HsVar var)
 292
 293       U_ap fun arg ->                   -- application
 294         wlkExpr fun     `thenUgn` \ expr1 ->
 295         wlkExpr arg     `thenUgn` \ expr2 ->
 296         returnUgn (HsApp expr1 expr2)
 297
 298       U_infixap fun arg1 arg2 ->        -- infix application
 299         wlkVarId  fun   `thenUgn` \ op    ->
 300         wlkExpr arg1    `thenUgn` \ expr1 ->
 301         wlkExpr arg2    `thenUgn` \ expr2 ->
 302         returnUgn (mkOpApp expr1 op expr2)
 303
 304       U_negate nexp ->                  -- prefix negation
 305         wlkExpr nexp    `thenUgn` \ expr ->
 306         returnUgn (NegApp expr (HsVar dummyRdrVarName))
 307
 308       U_llist llist -> -- explicit list
 309         wlkList rdExpr llist `thenUgn` \ exprs ->
 310         returnUgn (ExplicitList exprs)
 311
 312       U_tuple tuplelist -> -- explicit tuple
 313         wlkList rdExpr tuplelist `thenUgn` \ exprs ->
 314         returnUgn (ExplicitTuple exprs)
 315
 316       U_record con rbinds -> -- record construction
 317         wlkDataId  con          `thenUgn` \ rcon     ->
 318         wlkList rdRbind rbinds  `thenUgn` \ recbinds ->
 319         returnUgn (RecordCon (HsVar rcon) recbinds)
 320
 321       U_rupdate updexp updbinds -> -- record update
 322         wlkExpr updexp           `thenUgn` \ aexp ->
 323         wlkList rdRbind updbinds `thenUgn` \ recbinds ->
 324         returnUgn (RecordUpd aexp recbinds)
 325
 326 #ifdef DEBUG
 327       U_hmodule _ _ _ _ _ _ _ -> error "U_hmodule"
 328       U_as _ _                -> error "U_as"
 329       U_lazyp _               -> error "U_lazyp"
 330       U_wildp                 -> error "U_wildp"
 331       U_qual _ _              -> error "U_qual"
 332       U_guard _               -> error "U_guard"
 333       U_seqlet _              -> error "U_seqlet"
 334       U_dobind _ _ _          -> error "U_dobind"
 335       U_doexp _ _             -> error "U_doexp"
 336       U_rbind _ _             -> error "U_rbind"
 337       U_fixop _ _ _           -> error "U_fixop"
 338 #endif
 339
 340 rdRbind pt
 341   = rdU_tree pt         `thenUgn` \ (U_rbind var exp) ->
 342     wlkVarId   var      `thenUgn` \ rvar ->
 343     wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
 344     returnUgn (
 345       case expr_maybe of
 346         Nothing -> (rvar, HsVar rvar, True{-pun-})
 347         Just re -> (rvar, re,         False)
 348     )
 349
 350 wlkQuals cquals
 351   = wlkList rd_qual cquals
 352   where
 353           rd_qual pt
 354             = rdU_tree pt       `thenUgn` \ qual ->
 355               wlk_qual qual
 356
 357           wlk_qual qual
 358             = case qual of
 359                 U_guard exp ->
 360                   wlkExpr exp   `thenUgn` \ expr ->
 361                   getSrcLocUgn  `thenUgn` \ loc ->
 362                   returnUgn (GuardStmt expr loc)
 363
 364                 U_qual qpat qexp ->
 365                   wlkPat  qpat  `thenUgn` \ pat  ->
 366                   wlkExpr qexp  `thenUgn` \ expr ->
 367                   getSrcLocUgn  `thenUgn` \ loc ->
 368                   returnUgn (BindStmt pat expr loc)
 369
 370                 U_seqlet seqlet ->
 371                   wlkBinding seqlet     `thenUgn` \ bs ->
 372                   getSrcFileUgn         `thenUgn` \ sf ->
 373                   let
 374                       binds = cvBinds sf cvValSig bs
 375                   in
 376                   returnUgn (LetStmt binds)
 377                 U_let letvdefs letvexpr ->
 378                     wlkBinding letvdefs `thenUgn` \ binding ->
 379                     wlkExpr    letvexpr `thenUgn` \ expr    ->
 380                     getSrcLocUgn        `thenUgn` \ loc ->
 381                     getSrcFileUgn       `thenUgn` \ sf      ->
 382                     let
 383                      binds = cvBinds sf cvValSig binding
 384                     in
 385                     returnUgn (GuardStmt (HsLet binds expr) loc)
 386 \end{code}
 387
 388 Patterns: just bear in mind that lists of patterns are represented as
 389 a series of ``applications''.
 390 \begin{code}
 391 wlkPat pat
 392   = case pat of
 393       U_par ppat ->                     -- parenthesised pattern
 394         wlkPat ppat     `thenUgn` \ pat ->
 395         -- tidy things up a little:
 396         returnUgn (
 397         case pat of
 398           VarPatIn _ -> pat
 399           WildPatIn  -> pat
 400           other      -> ParPatIn pat
 401         )
 402
 403       U_as avar as_pat ->               -- "as" pattern
 404         wlkVarId avar   `thenUgn` \ var ->
 405         wlkPat as_pat   `thenUgn` \ pat ->
 406         returnUgn (AsPatIn var pat)
 407
 408       U_lazyp lazyp ->                  -- irrefutable ("twiddle") pattern
 409         wlkPat lazyp    `thenUgn` \ pat ->
 410         returnUgn (LazyPatIn pat)
 411
 412       U_plusp avar lit ->
 413         wlkVarId avar   `thenUgn` \ var ->
 414         wlkLiteral lit  `thenUgn` \ lit ->
 415         returnUgn (NPlusKPatIn var lit)
 416
 417       U_wildp -> returnUgn WildPatIn    -- wildcard pattern
 418
 419       U_lit lit ->                      -- literal pattern
 420         wlkLiteral lit  `thenUgn` \ lit ->
 421         returnUgn (LitPatIn lit)
 422
 423       U_ident nn ->                     -- simple identifier
 424         wlkVarId nn     `thenUgn` \ n ->
 425         returnUgn (
 426           case rdrNameOcc n of
 427                 VarOcc occ | isLexConId occ -> ConPatIn n []
 428                 other                       -> VarPatIn n
 429         )
 430
 431       U_ap l r ->       -- "application": there's a list of patterns lurking here!
 432         wlkPat r                `thenUgn` \ rpat         ->
 433         collect_pats l [rpat]   `thenUgn` \ (lpat,lpats) ->
 434         (case lpat of
 435             VarPatIn x          -> returnUgn (x,  lpats)
 436             ConPatIn x []       -> returnUgn (x,  lpats)
 437             ConOpPatIn x op _ y -> returnUgn (op, x:y:lpats)
 438             _ -> getSrcLocUgn   `thenUgn` \ loc ->
 439                  let
 440                      err = addErrLoc loc "Illegal pattern `application'"
 441                                      (\sty -> hsep (map (ppr sty) (lpat:lpats)))
 442                      msg = show (err (PprForUser opt_PprUserLength))
 443                  in
 444 #if __GLASGOW_HASKELL__ == 201
 445                  ioToUgnM  (GHCbase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ ->
 446                  ioToUgnM  (GHCbase.ioToPrimIO (ghcExit 1))          `thenUgn` \ _ ->
 447 #elif __GLASGOW_HASKELL__ >= 202
 448                  ioToUgnM  (IOBase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ ->
 449                  ioToUgnM  (IOBase.ioToPrimIO (ghcExit 1))           `thenUgn` \ _ ->
 450 #else
 451                  ioToUgnM  (hPutStr stderr msg) `thenUgn` \ _ ->
 452                  ioToUgnM  (ghcExit 1)          `thenUgn` \ _ ->
 453 #endif
 454                  returnUgn (error "ReadPrefix")
 455
 456         )                       `thenUgn` \ (n, arg_pats) ->
 457         returnUgn (ConPatIn n arg_pats)
 458         where
 459           collect_pats pat acc
 460             = case pat of
 461                 U_ap l r ->
 462                   wlkPat r      `thenUgn` \ rpat  ->
 463                   collect_pats l (rpat:acc)
 464                 other ->
 465                   wlkPat other  `thenUgn` \ pat ->
 466                   returnUgn (pat,acc)
 467
 468       U_infixap fun arg1 arg2 ->        -- infix pattern
 469         wlkVarId fun    `thenUgn` \ op   ->
 470         wlkPat arg1     `thenUgn` \ pat1 ->
 471         wlkPat arg2     `thenUgn` \ pat2 ->
 472         returnUgn (ConOpPatIn pat1 op (error "ConOpPatIn:fixity") pat2)
 473
 474       U_negate npat ->                  -- negated pattern
 475         wlkPat npat     `thenUgn` \ pat ->
 476         returnUgn (NegPatIn pat)
 477
 478       U_llist llist ->                  -- explicit list
 479         wlkList rdPat llist     `thenUgn` \ pats ->
 480         returnUgn (ListPatIn pats)
 481
 482       U_tuple tuplelist ->              -- explicit tuple
 483         wlkList rdPat tuplelist `thenUgn` \ pats ->
 484         returnUgn (TuplePatIn pats)
 485
 486       U_record con rpats ->             -- record destruction
 487         wlkDataId  con          `thenUgn` \ rcon     ->
 488         wlkList rdRpat rpats    `thenUgn` \ recpats ->
 489         returnUgn (RecPatIn rcon recpats)
 490         where
 491           rdRpat pt
 492             = rdU_tree pt        `thenUgn` \ (U_rbind var pat) ->
 493               wlkVarId   var     `thenUgn` \ rvar ->
 494               wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
 495               returnUgn (
 496                 case pat_maybe of
 497                   Nothing -> (rvar, VarPatIn rvar, True{-pun-})
 498                   Just rp -> (rvar, rp,            False)
 499               )
 500 \end{code}
 501
 502 \begin{code}
 503 wlkLiteral :: U_literal -> UgnM HsLit
 504
 505 wlkLiteral ulit
 506   = returnUgn (
 507     case ulit of
 508       U_integer    s -> HsInt        (as_integer  s)
 509       U_floatr     s -> HsFrac       (as_rational s)
 510       U_intprim    s -> HsIntPrim    (as_integer  s)
 511       U_doubleprim s -> HsDoublePrim (as_rational s)
 512       U_floatprim  s -> HsFloatPrim  (as_rational s)
 513       U_charr      s -> HsChar       (as_char     s)
 514       U_charprim   s -> HsCharPrim   (as_char     s)
 515       U_string     s -> HsString     (as_string   s)
 516       U_stringprim s -> HsStringPrim (as_string   s)
 517       U_clitlit    s -> HsLitLit     (as_string   s)
 518     )
 519   where
 520     as_char s     = _HEAD_ s
 521     as_integer s  = readInteger (_UNPK_ s)
 522 #if __GLASGOW_HASKELL__ == 201
 523     as_rational s = GHCbase.readRational__ (_UNPK_ s) -- non-std
 524 #elif __GLASGOW_HASKELL__ == 202
 525     as_rational s = case readRational (_UNPK_ s) of { [(a,_)] -> a }
 526 #elif __GLASGOW_HASKELL__ >= 203
 527     as_rational s = readRational__ (_UNPK_ s) -- use non-std readRational__
 528                                               -- to handle rationals with leading '-'
 529 #else
 530     as_rational s = _readRational (_UNPK_ s) -- non-std
 531 #endif
 532     as_string s   = s
 533 \end{code}
 534
 535 %************************************************************************
 536 %*                                                                      *
 537 \subsection{wlkBinding}
 538 %*                                                                      *
 539 %************************************************************************
 540
 541 \begin{code}
 542 wlkBinding :: U_binding -> UgnM RdrBinding
 543
 544 wlkBinding binding
 545   = case binding of
 546         -- null binding
 547       U_nullbind ->
 548         returnUgn RdrNullBind
 549
 550         -- "and" binding (just glue, really)
 551       U_abind a b ->
 552         wlkBinding a    `thenUgn` \ binding1 ->
 553         wlkBinding b    `thenUgn` \ binding2 ->
 554         returnUgn (RdrAndBindings binding1 binding2)
 555
 556         -- "data" declaration
 557       U_tbind tctxt ttype tcons tderivs srcline ->
 558         mkSrcLocUgn        srcline          $ \ src_loc     ->
 559         wlkContext         tctxt    `thenUgn` \ ctxt        ->
 560         wlkTyConAndTyVars  ttype    `thenUgn` \ (tycon, tyvars) ->
 561         wlkList rdConDecl  tcons    `thenUgn` \ cons        ->
 562         wlkDerivings       tderivs  `thenUgn` \ derivings   ->
 563         returnUgn (RdrTyDecl (TyData DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
 564
 565         -- "newtype" declaration
 566       U_ntbind ntctxt nttype ntcon ntderivs srcline ->
 567         mkSrcLocUgn        srcline          $ \ src_loc     ->
 568         wlkContext         ntctxt   `thenUgn` \ ctxt        ->
 569         wlkTyConAndTyVars  nttype   `thenUgn` \ (tycon, tyvars) ->
 570         wlkList rdConDecl  ntcon    `thenUgn` \ cons        ->
 571         wlkDerivings       ntderivs `thenUgn` \ derivings   ->
 572         returnUgn (RdrTyDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
 573
 574         -- "type" declaration
 575       U_nbind nbindid nbindas srcline ->
 576         mkSrcLocUgn       srcline         $ \ src_loc       ->
 577         wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
 578         wlkMonoType       nbindas `thenUgn` \ expansion     ->
 579         returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
 580
 581         -- function binding
 582       U_fbind fbindl srcline ->
 583         mkSrcLocUgn     srcline         $ \ src_loc ->
 584         wlkList rdMatch fbindl  `thenUgn` \ matches ->
 585         returnUgn (RdrFunctionBinding srcline matches)
 586
 587         -- pattern binding
 588       U_pbind pbindl srcline ->
 589         mkSrcLocUgn     srcline         $ \ src_loc ->
 590         wlkList rdMatch pbindl  `thenUgn` \ matches ->
 591         returnUgn (RdrPatternBinding srcline matches)
 592
 593         -- "class" declaration
 594       U_cbind cbindc cbindid cbindw srcline ->
 595         mkSrcLocUgn      srcline        $ \ src_loc       ->
 596         wlkContext       cbindc  `thenUgn` \ ctxt         ->
 597         wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)->
 598         wlkBinding       cbindw  `thenUgn` \ binding      ->
 599         getSrcFileUgn            `thenUgn` \ sf           ->
 600         let
 601             (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
 602         in
 603         returnUgn (RdrClassDecl
 604           (ClassDecl ctxt clas tyvar final_sigs final_methods noClassPragmas src_loc))
 605
 606         -- "instance" declaration
 607       U_ibind ibindc iclas ibindi ibindw srcline ->
 608         mkSrcLocUgn     srcline         $ \ src_loc ->
 609         wlkContext      ibindc  `thenUgn` \ ctxt    ->
 610         wlkTCId         iclas   `thenUgn` \ clas    ->
 611         wlkMonoType     ibindi  `thenUgn` \ at_ty ->
 612         wlkBinding      ibindw  `thenUgn` \ binding ->
 613         getSrcModUgn            `thenUgn` \ modname ->
 614         getSrcFileUgn           `thenUgn` \ sf      ->
 615         let
 616             (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
 617             inst_ty = HsPreForAllTy ctxt (MonoDictTy clas at_ty)
 618         in
 619         returnUgn (RdrInstDecl
 620           (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc))
 621
 622         -- "default" declaration
 623       U_dbind dbindts srcline ->
 624         mkSrcLocUgn        srcline      $ \ src_loc ->
 625         wlkList rdMonoType dbindts  `thenUgn` \ tys ->
 626         returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
 627
 628       a_sig_we_hope ->
 629         -- signature(-like) things, including user pragmas
 630         wlk_sig_thing a_sig_we_hope
 631 \end{code}
 632
 633 \begin{code}
 634 wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName])
 635
 636 wlkDerivings (U_nothing) = returnUgn Nothing
 637 wlkDerivings (U_just pt)
 638   = rdU_list pt          `thenUgn` \ ds     ->
 639     wlkList rdTCId ds    `thenUgn` \ derivs ->
 640     returnUgn (Just derivs)
 641 \end{code}
 642
 643 \begin{code}
 644         -- type signature
 645 wlk_sig_thing (U_sbind sbindids sbindid srcline)
 646   = mkSrcLocUgn         srcline         $ \ src_loc ->
 647     wlkList rdVarId     sbindids `thenUgn` \ vars    ->
 648     wlkHsType           sbindid  `thenUgn` \ poly_ty ->
 649     returnUgn (RdrTySig vars poly_ty src_loc)
 650
 651         -- value specialisation user-pragma
 652 wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
 653   = mkSrcLocUgn srcline                     $ \ src_loc ->
 654     wlkVarId  uvar                  `thenUgn` \ var ->
 655     wlkList rd_ty_and_id vspec_tys  `thenUgn` \ tys_and_ids ->
 656     returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
 657                              | (ty, using_id) <- tys_and_ids ])
 658   where
 659     rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
 660     rd_ty_and_id pt
 661       = rdU_binding pt          `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
 662         wlkHsType vspec_ty      `thenUgn` \ ty       ->
 663         wlkMaybe rdVarId vspec_id       `thenUgn` \ id_maybe ->
 664         returnUgn(ty, id_maybe)
 665
 666         -- instance specialisation user-pragma
 667 wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)
 668   = mkSrcLocUgn srcline                 $ \ src_loc ->
 669     wlkTCId     iclas           `thenUgn` \ clas    ->
 670     wlkMonoType ispec_ty        `thenUgn` \ ty      ->
 671     returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
 672
 673         -- data specialisation user-pragma
 674 wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
 675   = mkSrcLocUgn srcline                  $ \ src_loc ->
 676     wlkTCId     itycon           `thenUgn` \ tycon   ->
 677     wlkList rdMonoType dspec_tys `thenUgn` \ tys     ->
 678     returnUgn (RdrSpecDataSig (SpecDataSig tycon (foldl MonoTyApp (MonoTyVar tycon) tys) src_loc))
 679
 680         -- value inlining user-pragma
 681 wlk_sig_thing (U_inline_uprag ivar srcline)
 682   = mkSrcLocUgn srcline                 $ \ src_loc ->
 683     wlkVarId    ivar            `thenUgn` \ var     ->
 684     returnUgn (RdrInlineValSig (InlineSig var src_loc))
 685
 686         -- "deforest me" user-pragma
 687 wlk_sig_thing (U_deforest_uprag ivar srcline)
 688   = mkSrcLocUgn srcline                 $ \ src_loc ->
 689     wlkVarId    ivar            `thenUgn` \ var     ->
 690     returnUgn (RdrDeforestSig (DeforestSig var src_loc))
 691
 692         -- "magic" unfolding user-pragma
 693 wlk_sig_thing (U_magicuf_uprag ivar str srcline)
 694   = mkSrcLocUgn srcline                 $ \ src_loc ->
 695     wlkVarId    ivar            `thenUgn` \ var     ->
 696     returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
 697 \end{code}
 698
 699 %************************************************************************
 700 %*                                                                      *
 701 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
 702 %*                                                                      *
 703 %************************************************************************
 704
 705 \begin{code}
 706 rdHsType :: ParseTree -> UgnM RdrNameHsType
 707 rdMonoType :: ParseTree -> UgnM RdrNameHsType
 708
 709 rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
 710 rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
 711
 712 wlkHsType :: U_ttype -> UgnM RdrNameHsType
 713 wlkMonoType :: U_ttype -> UgnM RdrNameHsType
 714
 715 wlkHsType ttype
 716   = case ttype of
 717       U_context tcontextl tcontextt -> -- context
 718         wlkContext  tcontextl   `thenUgn` \ ctxt ->
 719         wlkMonoType tcontextt   `thenUgn` \ ty   ->
 720         returnUgn (HsPreForAllTy ctxt ty)
 721
 722       other -> -- something else
 723         wlkMonoType other   `thenUgn` \ ty ->
 724         returnUgn (HsPreForAllTy [{-no context-}] ty)
 725
 726 wlkMonoType ttype
 727   = case ttype of
 728                 -- Glasgow extension: nested polymorhism
 729       U_context tcontextl tcontextt -> -- context
 730         wlkContext  tcontextl   `thenUgn` \ ctxt ->
 731         wlkMonoType tcontextt   `thenUgn` \ ty   ->
 732         returnUgn (HsPreForAllTy ctxt ty)
 733
 734       U_namedtvar tv -> -- type variable
 735         wlkTvId tv      `thenUgn` \ tyvar ->
 736         returnUgn (MonoTyVar tyvar)
 737
 738       U_tname tcon -> -- type constructor
 739         wlkTCId tcon    `thenUgn` \ tycon ->
 740         returnUgn (MonoTyVar tycon)
 741
 742       U_tapp t1 t2 ->
 743         wlkMonoType t1          `thenUgn` \ ty1 ->
 744         wlkMonoType t2          `thenUgn` \ ty2 ->
 745         returnUgn (MonoTyApp ty1 ty2)
 746
 747       U_tllist tlist -> -- list type
 748         wlkMonoType tlist       `thenUgn` \ ty ->
 749         returnUgn (MonoListTy dummyRdrTcName ty)
 750
 751       U_ttuple ttuple ->
 752         wlkList rdMonoType ttuple `thenUgn` \ tys ->
 753         returnUgn (MonoTupleTy dummyRdrTcName tys)
 754
 755       U_tfun tfun targ ->
 756         wlkMonoType tfun        `thenUgn` \ ty1 ->
 757         wlkMonoType targ        `thenUgn` \ ty2 ->
 758         returnUgn (MonoFunTy ty1 ty2)
 759
 760 \end{code}
 761
 762 \begin{code}
 763 wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
 764 wlkContext        :: U_list  -> UgnM RdrNameContext
 765 wlkClassAssertTy  :: U_ttype -> UgnM (RdrName, HsTyVar RdrName)
 766
 767 wlkTyConAndTyVars ttype
 768   = wlkMonoType ttype   `thenUgn` \ ty ->
 769     let
 770         split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args)
 771         split (MonoTyVar tycon)               args = (tycon,args)
 772     in
 773     returnUgn (split ty [])
 774
 775 wlkContext list
 776   = wlkList rdMonoType list `thenUgn` \ tys ->
 777     returnUgn (map mk_class_assertion tys)
 778
 779 wlkClassAssertTy xs
 780   = wlkMonoType xs   `thenUgn` \ mono_ty ->
 781     returnUgn (case mk_class_assertion mono_ty of
 782                   (clas, MonoTyVar tyvar) -> (clas, UserTyVar tyvar)
 783     )
 784
 785 mk_class_assertion :: RdrNameHsType -> (RdrName, RdrNameHsType)
 786
 787 mk_class_assertion (MonoTyApp (MonoTyVar name) ty@(MonoTyVar tyname)) = (name, ty)
 788 mk_class_assertion other
 789   = pprError "ERROR: malformed type context: " (ppr (PprForUser opt_PprUserLength) other)
 790     -- regrettably, the parser does let some junk past
 791     -- e.g., f :: Num {-nothing-} => a -> ...
 792 \end{code}
 793
 794 \begin{code}
 795 rdConDecl :: ParseTree -> UgnM RdrNameConDecl
 796 rdConDecl pt
 797   = rdU_constr pt    `thenUgn` \ blah ->
 798     wlkConDecl blah
 799
 800 wlkConDecl :: U_constr -> UgnM RdrNameConDecl
 801
 802 wlkConDecl (U_constrcxt ccxt ccdecl)
 803   = wlkContext ccxt             `thenUgn` \ theta ->
 804     wlkConDecl ccdecl           `thenUgn` \ (ConDecl con _ details loc) ->
 805     returnUgn (ConDecl con theta details loc)
 806
 807 wlkConDecl (U_constrpre ccon ctys srcline)
 808   = mkSrcLocUgn srcline                 $ \ src_loc ->
 809     wlkDataId   ccon            `thenUgn` \ con     ->
 810     wlkList     rdBangType ctys `thenUgn` \ tys     ->
 811     returnUgn (ConDecl con [] (VanillaCon tys) src_loc)
 812
 813 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
 814   = mkSrcLocUgn srcline                 $ \ src_loc ->
 815     wlkBangType cty1            `thenUgn` \ ty1     ->
 816     wlkDataId   cop             `thenUgn` \ op      ->
 817     wlkBangType cty2            `thenUgn` \ ty2     ->
 818     returnUgn (ConDecl op [] (InfixCon ty1 ty2) src_loc)
 819
 820 wlkConDecl (U_constrnew ccon cty srcline)
 821   = mkSrcLocUgn srcline                 $ \ src_loc ->
 822     wlkDataId   ccon            `thenUgn` \ con     ->
 823     wlkMonoType cty             `thenUgn` \ ty      ->
 824     returnUgn (ConDecl con [] (NewCon ty) src_loc)
 825
 826 wlkConDecl (U_constrrec ccon cfields srcline)
 827   = mkSrcLocUgn srcline                 $ \ src_loc      ->
 828     wlkDataId   ccon            `thenUgn` \ con          ->
 829     wlkList rd_field cfields    `thenUgn` \ fields_lists ->
 830     returnUgn (ConDecl con [] (RecCon fields_lists) src_loc)
 831   where
 832     rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
 833     rd_field pt
 834       = rdU_constr pt           `thenUgn` \ (U_field fvars fty) ->
 835         wlkList rdVarId fvars   `thenUgn` \ vars ->
 836         wlkBangType fty         `thenUgn` \ ty ->
 837         returnUgn (vars, ty)
 838
 839 -----------------
 840 rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
 841
 842 wlkBangType :: U_ttype -> UgnM (BangType RdrName)
 843
 844 wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty ->
 845                             returnUgn (Banged   ty)
 846 wlkBangType uty           = wlkMonoType uty `thenUgn` \ ty ->
 847                             returnUgn (Unbanged ty)
 848 \end{code}
 849
 850 %************************************************************************
 851 %*                                                                      *
 852 \subsection{Read a ``match''}
 853 %*                                                                      *
 854 %************************************************************************
 855
 856 \begin{code}
 857 rdMatch :: ParseTree -> UgnM RdrMatch
 858
 859 rdMatch pt
 860   = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
 861     mkSrcLocUgn srcline                 $ \ src_loc      ->
 862     wlkPat      gpat            `thenUgn` \ pat     ->
 863     wlkBinding  gbind           `thenUgn` \ binding ->
 864     wlkVarId    gsrcfun         `thenUgn` \ srcfun  ->
 865     let
 866         wlk_guards (U_pnoguards exp)
 867           = wlkExpr exp `thenUgn` \ expr ->
 868             returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
 869
 870         wlk_guards (U_pguards gs)
 871           = wlkList rd_gd_expr gs   `thenUgn` \ gd_exps ->
 872             returnUgn (RdrMatch_Guards  srcline srcfun pat gd_exps binding)
 873     in
 874     wlk_guards gdexprs
 875   where
 876     rd_gd_expr pt
 877       = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
 878         wlkQuals     g  `thenUgn` \ guard ->
 879         wlkExpr      e  `thenUgn` \ expr  ->
 880         returnUgn (guard, expr)
 881 \end{code}
 882
 883 %************************************************************************
 884 %*                                                                      *
 885 \subsection[rdFixOp]{Read in a fixity declaration}
 886 %*                                                                      *
 887 %************************************************************************
 888
 889 \begin{code}
 890 rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl
 891 rdFixOp pt
 892   = rdU_tree pt `thenUgn` \ fix ->
 893     case fix of
 894       U_fixop op dir_n prec -> wlkVarId op `thenUgn` \ op ->
 895                                        returnUgn (FixityDecl op (Fixity prec dir) noSrcLoc)
 896                                                 -- ToDo: add SrcLoc!
 897                             where
 898                               dir = case dir_n of
 899                                         (-1) -> InfixL
 900                                         0    -> InfixN
 901                                         1    -> InfixR
 902       _ -> error "ReadPrefix:rdFixOp"
 903 \end{code}
 904
 905 %************************************************************************
 906 %*                                                                      *
 907 \subsection[rdImport]{Read an import decl}
 908 %*                                                                      *
 909 %************************************************************************
 910
 911 \begin{code}
 912 rdImport :: ParseTree
 913          -> UgnM RdrNameImportDecl
 914
 915 rdImport pt
 916   = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec isrc srcline) ->
 917     mkSrcLocUgn srcline                         $ \ src_loc      ->
 918     wlkMaybe rdU_stringId ias           `thenUgn` \ maybe_as    ->
 919     wlkMaybe rd_spec ispec              `thenUgn` \ maybe_spec  ->
 920     returnUgn (ImportDecl imod (cvFlag iqual) (cvIfaceFlavour isrc) maybe_as maybe_spec src_loc)
 921   where
 922     rd_spec pt = rdU_either pt          `thenUgn` \ spec ->
 923       case spec of
 924         U_left pt  -> rdEntities pt     `thenUgn` \ ents ->
 925                       returnUgn (False, ents)
 926         U_right pt -> rdEntities pt     `thenUgn` \ ents ->
 927                       returnUgn (True, ents)
 928
 929 cvIfaceFlavour 0 = HiFile       -- No pragam
 930 cvIfaceFlavour 1 = HiBootFile   -- {-# SOURCE #-}
 931 \end{code}
 932
 933 \begin{code}
 934 rdEntities pt
 935   = rdU_list pt             `thenUgn` \ list ->
 936     wlkList rdEntity list
 937
 938 rdEntity :: ParseTree -> UgnM (IE RdrName)
 939
 940 rdEntity pt
 941   = rdU_entidt pt `thenUgn` \ entity ->
 942     case entity of
 943       U_entid evar ->           -- just a value
 944         wlkEntId        evar            `thenUgn` \ var ->
 945         returnUgn (IEVar var)
 946
 947       U_enttype x ->            -- abstract type constructor/class
 948         wlkTCId x               `thenUgn` \ thing ->
 949         returnUgn (IEThingAbs thing)
 950
 951       U_enttypeall x ->         -- non-abstract type constructor/class
 952         wlkTCId x               `thenUgn` \ thing ->
 953         returnUgn (IEThingAll thing)
 954
 955       U_enttypenamed x ns ->    -- non-abstract type constructor/class
 956                                 -- with specified constrs/methods
 957         wlkTCId x               `thenUgn` \ thing ->
 958         wlkList rdVarId ns      `thenUgn` \ names ->
 959         returnUgn (IEThingWith thing names)
 960
 961       U_entmod mod ->           -- everything provided unqualified by a module
 962         returnUgn (IEModuleContents mod)
 963 \end{code}
 964