ghc/compiler/parser/RdrHsSyn.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996-1998
   3 %
   4 \section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader}
   5
   6 (Well, really, for specialisations involving @RdrName@s, even if
   7 they are used somewhat later on in the compiler...)
   8
   9 \begin{code}
  10 module RdrHsSyn (
  11         RdrNameArithSeqInfo,
  12         RdrNameBangType,
  13         RdrNameClassOpSig,
  14         RdrNameConDecl,
  15         RdrNameConDetails,
  16         RdrNameContext,
  17         RdrNameDefaultDecl,
  18         RdrNameForeignDecl,
  19         RdrNameCoreDecl,
  20         RdrNameGRHS,
  21         RdrNameGRHSs,
  22         RdrNameHsBinds,
  23         RdrNameHsDecl,
  24         RdrNameHsExpr,
  25         RdrNameHsModule,
  26         RdrNameIE,
  27         RdrNameImportDecl,
  28         RdrNameInstDecl,
  29         RdrNameMatch,
  30         RdrNameMonoBinds,
  31         RdrNamePat,
  32         RdrNameHsType,
  33         RdrNameHsTyVar,
  34         RdrNameSig,
  35         RdrNameStmt,
  36         RdrNameTyClDecl,
  37         RdrNameRuleDecl,
  38         RdrNameRuleBndr,
  39         RdrNameDeprecation,
  40         RdrNameHsRecordBinds,
  41         RdrNameFixitySig,
  42
  43         RdrBinding(..),
  44         RdrMatch(..),
  45
  46         main_RDR_Unqual,
  47
  48         extractHsTyRdrNames,  extractHsTyRdrTyVars,
  49         extractHsCtxtRdrTyVars, extractGenericPatTyVars,
  50
  51         mkHsOpApp, mkClassDecl, mkClassOpSigDM,
  52         mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
  53         mkHsDo, mkHsSplice, mkSigDecls,
  54         mkTyData, mkPrefixCon, mkRecCon,
  55         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
  56         mkIfaceExports,      -- :: [RdrNameTyClDecl] -> [RdrExportItem]
  57
  58         cvBinds,
  59         cvMonoBindsAndSigs,
  60         cvTopDecls,
  61         cvClassOpSig,
  62         findSplice, addImpDecls, emptyGroup, mkGroup,
  63
  64         -- Stuff to do with Foreign declarations
  65         , CallConv(..)
  66         , mkImport            -- CallConv -> Safety
  67                               -- -> (FastString, RdrName, RdrNameHsType)
  68                               -- -> SrcLoc
  69                               -- -> P RdrNameHsDecl
  70         , mkExport            -- CallConv
  71                               -- -> (FastString, RdrName, RdrNameHsType)
  72                               -- -> SrcLoc
  73                               -- -> P RdrNameHsDecl
  74         , mkExtName           -- RdrName -> CLabelString
  75
  76         -- Bunch of functions in the parser monad for
  77         -- checking and constructing values
  78         , checkPrecP          -- Int -> P Int
  79         , checkContext        -- HsType -> P HsContext
  80         , checkPred           -- HsType -> P HsPred
  81         , checkTyVars         -- [HsTyVar] -> P [HsType]
  82         , checkTyClHdr        -- HsType -> (name,[tyvar])
  83         , checkInstType       -- HsType -> P HsType
  84         , checkPattern        -- HsExp -> P HsPat
  85         , checkPatterns       -- SrcLoc -> [HsExp] -> P [HsPat]
  86         , checkDo             -- [Stmt] -> P [Stmt]
  87         , checkMDo            -- [Stmt] -> P [Stmt]
  88         , checkValDef         -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  89         , checkValSig         -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  90         , parseError          -- String -> Pa
  91     ) where
  92
  93 #include "HsVersions.h"
  94
  95 import HsSyn            -- Lots of it
  96 import RdrName          ( RdrName, isRdrTyVar, mkRdrUnqual, mkUnqual, rdrNameOcc,
  97                           isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
  98                           setRdrNameSpace )
  99 import BasicTypes       ( RecFlag(..), FixitySig(..), maxPrecedence )
 100 import Class            ( DefMeth (..) )
 101 import Lex              ( P, mapP, setSrcLocP, thenP, returnP, getSrcLocP, failMsgP )
 102 import HscTypes         ( RdrAvailInfo, GenAvailInfo(..) )
 103 import TysWiredIn       ( unitTyCon )
 104 import ForeignCall      ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
 105                           DNCallSpec(..))
 106 import OccName          ( srcDataName, varName, isDataOcc, isTcOcc, occNameUserString,
 107                           mkDefaultMethodOcc, mkVarOcc )
 108 import SrcLoc
 109 import CStrings         ( CLabelString )
 110 import List             ( isSuffixOf, nub )
 111 import Outputable
 112 import FastString
 113 import Panic
 114 \end{code}
 115
 116
 117 %************************************************************************
 118 %*                                                                      *
 119 \subsection{Type synonyms}
 120 %*                                                                      *
 121 %************************************************************************
 122
 123 \begin{code}
 124 type RdrNameArithSeqInfo        = ArithSeqInfo          RdrName
 125 type RdrNameBangType            = BangType              RdrName
 126 type RdrNameClassOpSig          = Sig                   RdrName
 127 type RdrNameConDecl             = ConDecl               RdrName
 128 type RdrNameConDetails          = HsConDetails          RdrName RdrNameBangType
 129 type RdrNameContext             = HsContext             RdrName
 130 type RdrNameHsDecl              = HsDecl                RdrName
 131 type RdrNameDefaultDecl         = DefaultDecl           RdrName
 132 type RdrNameForeignDecl         = ForeignDecl           RdrName
 133 type RdrNameCoreDecl            = CoreDecl              RdrName
 134 type RdrNameGRHS                = GRHS                  RdrName
 135 type RdrNameGRHSs               = GRHSs                 RdrName
 136 type RdrNameHsBinds             = HsBinds               RdrName
 137 type RdrNameHsExpr              = HsExpr                RdrName
 138 type RdrNameHsModule            = HsModule              RdrName
 139 type RdrNameIE                  = IE                    RdrName
 140 type RdrNameImportDecl          = ImportDecl            RdrName
 141 type RdrNameInstDecl            = InstDecl              RdrName
 142 type RdrNameMatch               = Match                 RdrName
 143 type RdrNameMonoBinds           = MonoBinds             RdrName
 144 type RdrNamePat                 = InPat                 RdrName
 145 type RdrNameHsType              = HsType                RdrName
 146 type RdrNameHsTyVar             = HsTyVarBndr           RdrName
 147 type RdrNameSig                 = Sig                   RdrName
 148 type RdrNameStmt                = Stmt                  RdrName
 149 type RdrNameTyClDecl            = TyClDecl              RdrName
 150
 151 type RdrNameRuleBndr            = RuleBndr              RdrName
 152 type RdrNameRuleDecl            = RuleDecl              RdrName
 153 type RdrNameDeprecation         = DeprecDecl            RdrName
 154 type RdrNameFixitySig           = FixitySig             RdrName
 155
 156 type RdrNameHsRecordBinds       = HsRecordBinds         RdrName
 157 \end{code}
 158
 159 \begin{code}
 160 main_RDR_Unqual :: RdrName
 161 main_RDR_Unqual = mkUnqual varName FSLIT("main")
 162         -- We definitely don't want an Orig RdrName, because
 163         -- main might, in principle, be imported into module Main
 164 \end{code}
 165
 166 %************************************************************************
 167 %*                                                                      *
 168 \subsection{A few functions over HsSyn at RdrName}
 169 %*                                                                    *
 170 %************************************************************************
 171
 172 @extractHsTyRdrNames@ finds the free variables of a HsType
 173 It's used when making the for-alls explicit.
 174
 175 \begin{code}
 176 extractHsTyRdrNames :: RdrNameHsType -> [RdrName]
 177 extractHsTyRdrNames ty = nub (extract_ty ty [])
 178
 179 extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
 180 extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty []))
 181
 182 extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
 183 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
 184 extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
 185 extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
 186
 187 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
 188
 189 extract_pred (HsClassP cls tys) acc     = foldr extract_ty (cls : acc) tys
 190 extract_pred (HsIParam n ty) acc        = extract_ty ty acc
 191
 192 extract_tys tys = foldr extract_ty [] tys
 193
 194 extract_ty (HsAppTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
 195 extract_ty (HsListTy ty)              acc = extract_ty ty acc
 196 extract_ty (HsPArrTy ty)              acc = extract_ty ty acc
 197 extract_ty (HsTupleTy _ tys)          acc = foldr extract_ty acc tys
 198 extract_ty (HsFunTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
 199 extract_ty (HsPredTy p)               acc = extract_pred p acc
 200 extract_ty (HsTyVar tv)               acc = tv : acc
 201 extract_ty (HsForAllTy Nothing cx ty) acc = extract_ctxt cx (extract_ty ty acc)
 202 extract_ty (HsOpTy ty1 nam ty2)       acc = extract_ty ty1 (extract_ty ty2 acc)
 203 extract_ty (HsParTy ty)               acc = extract_ty ty acc
 204 -- Generics
 205 extract_ty (HsNumTy num)              acc = acc
 206 extract_ty (HsKindSig ty k)           acc = extract_ty ty acc
 207 extract_ty (HsForAllTy (Just tvs) ctxt ty)
 208                                 acc = acc ++
 209                                       (filter (`notElem` locals) $
 210                                        extract_ctxt ctxt (extract_ty ty []))
 211                                     where
 212                                       locals = hsTyVarNames tvs
 213
 214 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
 215 -- Get the type variables out of the type patterns in a bunch of
 216 -- possibly-generic bindings in a class declaration
 217 extractGenericPatTyVars binds
 218   = filter isRdrTyVar (nub (get binds []))
 219   where
 220     get (AndMonoBinds b1 b2)   acc = get b1 (get b2 acc)
 221     get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
 222     get other                  acc = acc
 223
 224     get_m (Match (TypePat ty : _) _ _) acc = extract_ty ty acc
 225     get_m other                        acc = acc
 226 \end{code}
 227
 228
 229 %************************************************************************
 230 %*                                                                      *
 231 \subsection{Construction functions for Rdr stuff}
 232 %*                                                                    *
 233 %************************************************************************
 234
 235 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
 236 by deriving them from the name of the class.  We fill in the names for the
 237 tycon and datacon corresponding to the class, by deriving them from the
 238 name of the class itself.  This saves recording the names in the interface
 239 file (which would be equally good).
 240
 241 Similarly for mkConDecl, mkClassOpSig and default-method names.
 242
 243         *** See "THE NAMING STORY" in HsDecls ****
 244
 245 \begin{code}
 246 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc
 247   = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
 248                 tcdFDs = fds,  tcdSigs = sigs,  tcdMeths = mbinds,
 249                 tcdLoc = loc }
 250
 251 mkTyData new_or_data (context, tname, tyvars) data_cons maybe src
 252   = TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
 253              tcdTyVars = tyvars,  tcdCons = data_cons,
 254              tcdDerivs = maybe,   tcdLoc = src, tcdGeneric = Nothing }
 255
 256 mkClassOpSigDM op ty loc
 257   = ClassOpSig op (DefMeth dm_rn) ty loc
 258   where
 259     dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
 260 \end{code}
 261
 262 \begin{code}
 263 mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
 264 -- If the type checker sees (negate 3#) it will barf, because negate
 265 -- can't take an unboxed arg.  But that is exactly what it will see when
 266 -- we write "-3#".  So we have to do the negation right now!
 267
 268 mkHsNegApp (HsLit (HsIntPrim i))    = HsLit (HsIntPrim (-i))
 269 mkHsNegApp (HsLit (HsFloatPrim i))  = HsLit (HsFloatPrim (-i))
 270 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
 271 mkHsNegApp expr                     = NegApp expr     placeHolderName
 272 \end{code}
 273
 274 A useful function for building @OpApps@.  The operator is always a
 275 variable, and we don't know the fixity yet.
 276
 277 \begin{code}
 278 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
 279 \end{code}
 280
 281 These are the bits of syntax that contain rebindable names
 282 See RnEnv.lookupSyntaxName
 283
 284 \begin{code}
 285 mkHsIntegral   i      = HsIntegral   i  placeHolderName
 286 mkHsFractional f      = HsFractional f  placeHolderName
 287 mkNPlusKPat n k       = NPlusKPatIn n k placeHolderName
 288 mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc
 289 \end{code}
 290
 291 \begin{code}
 292 mkHsSplice e loc = HsSplice unqualSplice e loc
 293
 294 unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
 295                 -- A name (uniquified later) to
 296                 -- identify the splice
 297 \end{code}
 298
 299 %************************************************************************
 300 %*                                                                      *
 301 \subsection[rdrBinding]{Bindings straight out of the parser}
 302 %*                                                                      *
 303 %************************************************************************
 304
 305 \begin{code}
 306 data RdrBinding
 307   =   -- Value bindings havn't been united with their
 308       -- signatures yet
 309     RdrBindings [RdrBinding]    -- Convenience for parsing
 310
 311   | RdrValBinding     RdrNameMonoBinds
 312
 313       -- The remainder all fit into the main HsDecl form
 314   | RdrHsDecl         RdrNameHsDecl
 315 \end{code}
 316
 317 \begin{code}
 318 data RdrMatch
 319   = RdrMatch
 320              [RdrNamePat]
 321              (Maybe RdrNameHsType)
 322              RdrNameGRHSs
 323 \end{code}
 324
 325 %************************************************************************
 326 %*                                                                      *
 327 \subsection[cvDecls]{Convert various top-level declarations}
 328 %*                                                                      *
 329 %************************************************************************
 330
 331 We make a point not to throw any user-pragma ``sigs'' at
 332 these conversion functions:
 333
 334 \begin{code}
 335 cvClassOpSig :: RdrNameSig -> RdrNameSig
 336 cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc
 337 cvClassOpSig sig                       = sig
 338 \end{code}
 339
 340
 341 %************************************************************************
 342 %*                                                                      *
 343 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
 344 %*                                                                      *
 345 %************************************************************************
 346
 347 Function definitions are restructured here. Each is assumed to be recursive
 348 initially, and non recursive definitions are discovered by the dependency
 349 analyser.
 350
 351
 352 \begin{code}
 353 cvTopDecls :: [RdrBinding] -> [RdrNameHsDecl]
 354 -- Incoming bindings are in reverse order; result is in ordinary order
 355 -- (a) flatten RdrBindings
 356 -- (b) Group together bindings for a single function
 357 cvTopDecls decls
 358   = go [] decls
 359   where
 360     go :: [RdrNameHsDecl] -> [RdrBinding] -> [RdrNameHsDecl]
 361     go acc []                      = acc
 362     go acc (RdrBindings ds1 : ds2) = go (go acc ds1)    ds2
 363     go acc (RdrHsDecl d : ds)      = go (d       : acc) ds
 364     go acc (RdrValBinding b : ds)  = go (ValD b' : acc) ds'
 365                                    where
 366                                      (b', ds') = getMonoBind b ds
 367
 368 cvBinds :: [RdrBinding] -> RdrNameHsBinds
 369 cvBinds binding
 370   = case (cvMonoBindsAndSigs binding) of { (mbs, sigs) ->
 371     MonoBind mbs sigs Recursive
 372     }
 373
 374 cvMonoBindsAndSigs :: [RdrBinding] -> (RdrNameMonoBinds, [RdrNameSig])
 375 -- Input bindings are in *reverse* order,
 376 -- and contain just value bindings and signatuers
 377
 378 cvMonoBindsAndSigs  fb
 379   = go (EmptyMonoBinds, []) fb
 380   where
 381     go acc      []                        = acc
 382     go acc      (RdrBindings ds1 : ds2)   = go (go acc ds1) ds2
 383     go (bs, ss) (RdrHsDecl (SigD s) : ds) = go (bs, s : ss) ds
 384     go (bs, ss) (RdrValBinding b : ds)    = go (b' `AndMonoBinds` bs, ss) ds'
 385                                           where
 386                                             (b',ds') = getMonoBind b ds
 387
 388 -----------------------------------------------------------------------------
 389 -- Group function bindings into equation groups
 390
 391 getMonoBind :: RdrNameMonoBinds -> [RdrBinding] -> (RdrNameMonoBinds, [RdrBinding])
 392 -- Suppose      (b',ds') = getMonoBind b ds
 393 --      ds is a *reversed* list of parsed bindings
 394 --      b is a MonoBinds that has just been read off the front
 395
 396 -- Then b' is the result of grouping more equations from ds that
 397 -- belong with b into a single MonoBinds, and ds' is the depleted
 398 -- list of parsed bindings.
 399 --
 400 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 401
 402 getMonoBind (FunMonoBind f inf mtchs loc) binds
 403   | has_args mtchs
 404   = go mtchs loc binds
 405   where
 406     go mtchs1 loc1 (RdrValBinding (FunMonoBind f2 inf2 mtchs2 loc2) : binds)
 407         | f == f2 = go (mtchs2 ++ mtchs1) loc2 binds
 408         -- Remember binds is reversed, so glue mtchs2 on the front
 409         -- and use loc2 as the final location
 410     go mtchs1 loc1 binds = (FunMonoBind f inf mtchs1 loc1, binds)
 411
 412 getMonoBind bind binds = (bind, binds)
 413
 414 has_args ((Match args _ _) : _) = not (null args)
 415         -- Don't group together FunMonoBinds if they have
 416         -- no arguments.  This is necessary now that variable bindings
 417         -- with no arguments are now treated as FunMonoBinds rather
 418         -- than pattern bindings (tests/rename/should_fail/rnfail002).
 419 \end{code}
 420
 421 \begin{code}
 422 emptyGroup = HsGroup { hs_valds = MonoBind EmptyMonoBinds [] Recursive,
 423                         -- The renamer adds structure to the bindings;
 424                         -- they start life as a single giant MonoBinds
 425                        hs_tyclds = [], hs_instds = [],
 426                        hs_fixds = [], hs_defds = [], hs_fords = [],
 427                        hs_depds = [] ,hs_ruleds = [], hs_coreds = [] }
 428
 429 findSplice :: [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a]))
 430 findSplice ds = add emptyGroup ds
 431
 432 mkGroup :: [HsDecl a] -> HsGroup a
 433 mkGroup ds = addImpDecls emptyGroup ds
 434
 435 addImpDecls :: HsGroup a -> [HsDecl a] -> HsGroup a
 436 -- The decls are imported, and should not have a splice
 437 addImpDecls group decls = case add group decls of
 438                                 (group', Nothing) -> group'
 439                                 other             -> panic "addImpDecls"
 440
 441 add :: HsGroup a -> [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a]))
 442         -- This stuff reverses the declarations (again) but it doesn't matter
 443
 444 -- Base cases
 445 add gp []               = (gp, Nothing)
 446 add gp (SpliceD e : ds) = (gp, Just (e, ds))
 447
 448 -- Class declarations: pull out the fixity signatures to the top
 449 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) (TyClD d : ds)
 450         | isClassDecl d = add (gp { hs_tyclds = d : ts,
 451                                     hs_fixds  = [f | FixSig f <- tcdSigs d] ++ fs }) ds
 452         | otherwise     = add (gp { hs_tyclds = d : ts }) ds
 453
 454 -- Signatures: fixity sigs go a different place than all others
 455 add gp@(HsGroup {hs_fixds = ts}) (SigD (FixSig f) : ds) = add (gp {hs_fixds = f : ts}) ds
 456 add gp@(HsGroup {hs_valds = ts}) (SigD d : ds)          = add (gp {hs_valds = add_sig d ts}) ds
 457
 458 -- Value declarations: use add_bind
 459 add gp@(HsGroup {hs_valds  = ts}) (ValD d : ds) = add (gp { hs_valds = add_bind d ts }) ds
 460
 461 -- The rest are routine
 462 add gp@(HsGroup {hs_instds = ts}) (InstD d : ds)   = add (gp { hs_instds = d : ts }) ds
 463 add gp@(HsGroup {hs_defds  = ts}) (DefD d : ds)    = add (gp { hs_defds = d : ts }) ds
 464 add gp@(HsGroup {hs_fords  = ts}) (ForD d : ds)    = add (gp { hs_fords = d : ts }) ds
 465 add gp@(HsGroup {hs_depds  = ts}) (DeprecD d : ds) = add (gp { hs_depds = d : ts }) ds
 466 add gp@(HsGroup {hs_ruleds  = ts})(RuleD d : ds)   = add (gp { hs_ruleds = d : ts }) ds
 467 add gp@(HsGroup {hs_coreds  = ts})(CoreD d : ds)   = add (gp { hs_coreds = d : ts }) ds
 468
 469 add_bind b (MonoBind bs sigs r) = MonoBind (bs `AndMonoBinds` b) sigs r
 470 add_sig  s (MonoBind bs sigs r) = MonoBind bs                (s:sigs) r
 471 \end{code}
 472
 473 %************************************************************************
 474 %*                                                                      *
 475 \subsection[PrefixToHS-utils]{Utilities for conversion}
 476 %*                                                                      *
 477 %************************************************************************
 478
 479
 480 \begin{code}
 481 -----------------------------------------------------------------------------
 482 -- mkPrefixCon
 483
 484 -- When parsing data declarations, we sometimes inadvertently parse
 485 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
 486 -- This function splits up the type application, adds any pending
 487 -- arguments, and converts the type constructor back into a data constructor.
 488
 489 mkPrefixCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
 490
 491 mkPrefixCon ty tys
 492  = split ty tys
 493  where
 494    split (HsAppTy t u)  ts = split t (unbangedType u : ts)
 495    split (HsTyVar tc)   ts = tyConToDataCon tc  `thenP` \ data_con ->
 496                              returnP (data_con, PrefixCon ts)
 497    split _               _ = parseError "Illegal data/newtype declaration"
 498
 499 mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
 500 mkRecCon con fields
 501   = tyConToDataCon con  `thenP` \ data_con ->
 502     returnP (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
 503
 504 tyConToDataCon :: RdrName -> P RdrName
 505 tyConToDataCon tc
 506   | isTcOcc (rdrNameOcc tc)
 507   = returnP (setRdrNameSpace tc srcDataName)
 508   | otherwise
 509   = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
 510
 511 ----------------------------------------------------------------------------
 512 -- Various Syntactic Checks
 513
 514 checkInstType :: RdrNameHsType -> P RdrNameHsType
 515 checkInstType t
 516   = case t of
 517         HsForAllTy tvs ctxt ty ->
 518                 checkDictTy ty [] `thenP` \ dict_ty ->
 519                 returnP (HsForAllTy tvs ctxt dict_ty)
 520
 521         HsParTy ty -> checkInstType ty
 522
 523         ty ->   checkDictTy ty [] `thenP` \ dict_ty->
 524                 returnP (HsForAllTy Nothing [] dict_ty)
 525
 526 checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar]
 527 checkTyVars tvs
 528   = mapP chk tvs
 529   where
 530         --  Check that the name space is correct!
 531     chk (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = returnP (IfaceTyVar tv k)
 532     chk (HsTyVar tv)               | isRdrTyVar tv = returnP (UserTyVar tv)
 533     chk other                      = parseError "Type found where type variable expected"
 534
 535 checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar])
 536 -- The header of a type or class decl should look like
 537 --      (C a, D b) => T a b
 538 -- or   T a b
 539 -- or   a + b
 540 -- etc
 541 checkTyClHdr ty
 542   = go ty []
 543   where
 544     go (HsTyVar tc)    acc
 545         | not (isRdrTyVar tc) = checkTyVars acc         `thenP` \ tvs ->
 546                                 returnP (tc, tvs)
 547     go (HsOpTy t1 (HsTyOp tc) t2) acc
 548                               = checkTyVars (t1:t2:acc) `thenP` \ tvs ->
 549                                 returnP (tc, tvs)
 550     go (HsParTy ty)    acc    = go ty acc
 551     go (HsAppTy t1 t2) acc    = go t1 (t2:acc)
 552     go other           acc    = parseError "Malformed LHS to type of class declaration"
 553
 554 checkContext :: RdrNameHsType -> P RdrNameContext
 555 checkContext (HsTupleTy _ ts)   -- (Eq a, Ord b) shows up as a tuple type
 556   = mapP checkPred ts
 557
 558 checkContext (HsParTy ty)       -- to be sure HsParTy doesn't get into the way
 559   = checkContext ty
 560
 561 checkContext (HsTyVar t)        -- Empty context shows up as a unit type ()
 562   | t == getRdrName unitTyCon = returnP []
 563
 564 checkContext t
 565   = checkPred t `thenP` \p ->
 566     returnP [p]
 567
 568 checkPred :: RdrNameHsType -> P (HsPred RdrName)
 569 -- Watch out.. in ...deriving( Show )... we use checkPred on
 570 -- the list of partially applied predicates in the deriving,
 571 -- so there can be zero args.
 572 checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty)
 573 checkPred ty
 574   = go ty []
 575   where
 576     go (HsTyVar t) args   | not (isRdrTyVar t)
 577                           = returnP (HsClassP t args)
 578     go (HsAppTy l r) args = go l (r:args)
 579     go (HsParTy t)   args = go t args
 580     go _             _    = parseError "Illegal class assertion"
 581
 582 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
 583 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
 584         = returnP (mkHsDictTy t args)
 585 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
 586 checkDictTy (HsParTy t)   args = checkDictTy t args
 587 checkDictTy _ _ = parseError "Malformed context in instance header"
 588
 589
 590 ---------------------------------------------------------------------------
 591 -- Checking statements in a do-expression
 592 --      We parse   do { e1 ; e2 ; }
 593 --      as [ExprStmt e1, ExprStmt e2]
 594 -- checkDo (a) checks that the last thing is an ExprStmt
 595 --         (b) transforms it to a ResultStmt
 596 -- same comments apply for mdo as well
 597
 598 checkDo  = checkDoMDo "a " "'do'"
 599 checkMDo = checkDoMDo "an " "'mdo'"
 600
 601 checkDoMDo _   nm []               = parseError $ "Empty " ++ nm ++ " construct"
 602 checkDoMDo _   _  [ExprStmt e _ l] = returnP [ResultStmt e l]
 603 checkDoMDo pre nm [s]              = parseError $ "The last statement in " ++ pre ++ nm ++ " construct must be an expression"
 604 checkDoMDo pre nm (s:ss)           = checkDoMDo pre nm ss       `thenP` \ ss' ->
 605                                      returnP (s:ss')
 606
 607 ---------------------------------------------------------------------------
 608 -- Checking Patterns.
 609
 610 -- We parse patterns as expressions and check for valid patterns below,
 611 -- converting the expression into a pattern at the same time.
 612
 613 checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
 614 checkPattern loc e = setSrcLocP loc (checkPat e [])
 615
 616 checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
 617 checkPatterns loc es = mapP (checkPattern loc) es
 618
 619 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
 620 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c (PrefixCon args))
 621 checkPat (HsApp f x) args =
 622         checkPat x [] `thenP` \x ->
 623         checkPat f (x:args)
 624 checkPat e [] = case e of
 625         EWildPat            -> returnP (WildPat placeHolderType)
 626         HsVar x | isQual x  -> parseError ("Qualified variable in pattern: " ++ showRdrName x)
 627                 | otherwise -> returnP (VarPat x)
 628         HsLit l            -> returnP (LitPat l)
 629         HsOverLit l        -> returnP (NPatIn l Nothing)
 630         ELazyPat e         -> checkPat e [] `thenP` (returnP . LazyPat)
 631         EAsPat n e         -> checkPat e [] `thenP` (returnP . AsPat n)
 632         ExprWithTySig e t  -> checkPat e [] `thenP` \e ->
 633                               -- Pattern signatures are parsed as sigtypes,
 634                               -- but they aren't explicit forall points.  Hence
 635                               -- we have to remove the implicit forall here.
 636                               let t' = case t of
 637                                           HsForAllTy Nothing [] ty -> ty
 638                                           other -> other
 639                               in
 640                               returnP (SigPatIn e t')
 641
 642         -- Translate out NegApps of literals in patterns. We negate
 643         -- the Integer here, and add back the call to 'negate' when
 644         -- we typecheck the pattern.
 645         -- NB. Negative *primitive* literals are already handled by
 646         --     RdrHsSyn.mkHsNegApp
 647         NegApp (HsOverLit lit) neg -> returnP (NPatIn lit (Just neg))
 648
 649         OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
 650                            | plus == plus_RDR
 651                            -> returnP (mkNPlusKPat n lit)
 652                            where
 653                               plus_RDR = mkUnqual varName FSLIT("+")    -- Hack
 654
 655         OpApp l op fix r   -> checkPat l [] `thenP` \l ->
 656                               checkPat r [] `thenP` \r ->
 657                               case op of
 658                                  HsVar c | isDataOcc (rdrNameOcc c)
 659                                         -> returnP (ConPatIn c (InfixCon l r))
 660                                  _ -> patFail
 661
 662         HsPar e            -> checkPat e [] `thenP` (returnP . ParPat)
 663         ExplicitList _ es  -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 664                               returnP (ListPat ps placeHolderType)
 665         ExplicitPArr _ es  -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 666                               returnP (PArrPat ps placeHolderType)
 667
 668         ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 669                               returnP (TuplePat ps b)
 670
 671         RecordCon c fs     -> mapP checkPatField fs `thenP` \fs ->
 672                               returnP (ConPatIn c (RecCon fs))
 673 -- Generics
 674         HsType ty          -> returnP (TypePat ty)
 675         _                  -> patFail
 676
 677 checkPat _ _ = patFail
 678
 679 checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat)
 680 checkPatField (n,e) = checkPat e [] `thenP` \p ->
 681                       returnP (n,p)
 682
 683 patFail = parseError "Parse error in pattern"
 684
 685
 686 ---------------------------------------------------------------------------
 687 -- Check Equation Syntax
 688
 689 checkValDef
 690         :: RdrNameHsExpr
 691         -> Maybe RdrNameHsType
 692         -> RdrNameGRHSs
 693         -> SrcLoc
 694         -> P RdrBinding
 695
 696 checkValDef lhs opt_sig grhss loc
 697  = case isFunLhs lhs [] of
 698            Just (f,inf,es)
 699              | isQual f
 700              -> parseError ("Qualified name in function definition: "  ++ showRdrName f)
 701              | otherwise
 702              -> checkPatterns loc es `thenP` \ps ->
 703                 returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
 704
 705            Nothing ->
 706                 checkPattern loc lhs `thenP` \lhs ->
 707                 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
 708
 709 checkValSig
 710         :: RdrNameHsExpr
 711         -> RdrNameHsType
 712         -> SrcLoc
 713         -> P RdrBinding
 714 checkValSig (HsVar v) ty loc | isUnqual v = returnP (RdrHsDecl (SigD (Sig v ty loc)))
 715 checkValSig other     ty loc = parseError "Type signature given for an expression"
 716
 717 mkSigDecls :: [Sig RdrName] -> RdrBinding
 718 mkSigDecls sigs = RdrBindings [RdrHsDecl (SigD sig) | sig <- sigs]
 719
 720
 721 -- A variable binding is parsed as an RdrNameFunMonoBind.
 722 -- See comments with HsBinds.MonoBinds
 723
 724 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
 725 isFunLhs (OpApp l (HsVar op) fix r) es  | not (isRdrDataCon op)
 726                                 = Just (op, True, (l:r:es))
 727                                         | otherwise
 728                                 = case isFunLhs l es of
 729                                     Just (op', True, j : k : es') ->
 730                                       Just (op', True, j : OpApp k (HsVar op) fix r : es')
 731                                     _ -> Nothing
 732 isFunLhs (HsVar f) es | not (isRdrDataCon f)
 733                                 = Just (f,False,es)
 734 isFunLhs (HsApp f e) es         = isFunLhs f (e:es)
 735 isFunLhs (HsPar e)   es@(_:_)   = isFunLhs e es
 736 isFunLhs _ _                    = Nothing
 737
 738 ---------------------------------------------------------------------------
 739 -- Miscellaneous utilities
 740
 741 checkPrecP :: Int -> P Int
 742 checkPrecP i | 0 <= i && i <= maxPrecedence = returnP i
 743              | otherwise                    = parseError "Precedence out of range"
 744
 745 mkRecConstrOrUpdate
 746         :: RdrNameHsExpr
 747         -> RdrNameHsRecordBinds
 748         -> P RdrNameHsExpr
 749
 750 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
 751   = returnP (RecordCon c fs)
 752 mkRecConstrOrUpdate exp fs@(_:_)
 753   = returnP (RecordUpd exp fs)
 754 mkRecConstrOrUpdate _ _
 755   = parseError "Empty record update"
 756
 757 -----------------------------------------------------------------------------
 758 -- utilities for foreign declarations
 759
 760 -- supported calling conventions
 761 --
 762 data CallConv = CCall  CCallConv        -- ccall or stdcall
 763               | DNCall                  -- .NET
 764
 765 -- construct a foreign import declaration
 766 --
 767 mkImport :: CallConv
 768          -> Safety
 769          -> (FastString, RdrName, RdrNameHsType)
 770          -> SrcLoc
 771          -> P RdrNameHsDecl
 772 mkImport (CCall  cconv) safety (entity, v, ty) loc =
 773   parseCImport entity cconv safety v                     `thenP` \importSpec ->
 774   returnP $ ForD (ForeignImport v ty importSpec                     False loc)
 775 mkImport (DNCall      ) _      (entity, v, ty) loc =
 776   returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc)
 777
 778 -- parse the entity string of a foreign import declaration for the `ccall' or
 779 -- `stdcall' calling convention'
 780 --
 781 parseCImport :: FastString
 782              -> CCallConv
 783              -> Safety
 784              -> RdrName
 785              -> P ForeignImport
 786 parseCImport entity cconv safety v
 787   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
 788   | entity == FSLIT ("dynamic") =
 789     returnP $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
 790   | entity == FSLIT ("wrapper") =
 791     returnP $ CImport cconv safety nilFS nilFS CWrapper
 792   | otherwise                  = parse0 (unpackFS entity)
 793     where
 794       -- using the static keyword?
 795       parse0 (' ':                    rest) = parse0 rest
 796       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
 797       parse0                          rest  = parse1 rest
 798       -- check for header file name
 799       parse1     ""               = parse4 ""    nilFS        False nilFS
 800       parse1     (' ':rest)       = parse1 rest
 801       parse1 str@('&':_   )       = parse2 str   nilFS
 802       parse1 str@('[':_   )       = parse3 str   nilFS        False
 803       parse1 str
 804         | ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
 805         | otherwise               = parse4 str   nilFS        False nilFS
 806         where
 807           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
 808       -- check for address operator (indicating a label import)
 809       parse2     ""         header = parse4 ""   header False nilFS
 810       parse2     (' ':rest) header = parse2 rest header
 811       parse2     ('&':rest) header = parse3 rest header True
 812       parse2 str@('[':_   ) header = parse3 str  header False
 813       parse2 str            header = parse4 str  header False nilFS
 814       -- check for library object name
 815       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
 816       parse3 ('[':rest) header isLbl =
 817         case break (== ']') rest of
 818           (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
 819           _                         -> parseError "Missing ']' in entity"
 820       parse3 str        header isLbl = parse4 str  header isLbl nilFS
 821       -- check for name of C function
 822       parse4 ""         header isLbl lib = build (mkExtName v) header isLbl lib
 823       parse4 (' ':rest) header isLbl lib = parse4 rest         header isLbl lib
 824       parse4 str        header isLbl lib
 825         | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
 826         | otherwise                      = parseError "Malformed entity string"
 827         where
 828           (first, rest) = break (== ' ') str
 829       --
 830       build cid header False lib = returnP $
 831         CImport cconv safety header lib (CFunction (StaticTarget cid))
 832       build cid header True  lib = returnP $
 833         CImport cconv safety header lib (CLabel                  cid )
 834
 835 -- construct a foreign export declaration
 836 --
 837 mkExport :: CallConv
 838          -> (FastString, RdrName, RdrNameHsType)
 839          -> SrcLoc
 840          -> P RdrNameHsDecl
 841 mkExport (CCall  cconv) (entity, v, ty) loc = returnP $
 842   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
 843   where
 844     entity' | nullFastString entity = mkExtName v
 845             | otherwise             = entity
 846 mkExport DNCall (entity, v, ty) loc =
 847   parseError "Foreign export is not yet supported for .NET"
 848
 849 -- Supplying the ext_name in a foreign decl is optional; if it
 850 -- isn't there, the Haskell name is assumed. Note that no transformation
 851 -- of the Haskell name is then performed, so if you foreign export (++),
 852 -- it's external name will be "++". Too bad; it's important because we don't
 853 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 854 -- (This is why we use occNameUserString.)
 855 --
 856 mkExtName :: RdrName -> CLabelString
 857 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
 858
 859 -- ---------------------------------------------------------------------------
 860 -- Make the export list for an interface
 861
 862 mkIfaceExports :: [RdrNameTyClDecl] -> [RdrAvailInfo]
 863 mkIfaceExports decls = map getExport decls
 864   where getExport d = case d of
 865                         TyData{}    -> tc_export
 866                         ClassDecl{} -> tc_export
 867                         _other      -> var_export
 868           where
 869                 tc_export  = AvailTC (rdrNameOcc (tcdName d))
 870                                 (map (rdrNameOcc.fst) (tyClDeclNames d))
 871                 var_export = Avail (rdrNameOcc (tcdName d))
 872 \end{code}
 873
 874
 875 -----------------------------------------------------------------------------
 876 -- Misc utils
 877
 878 \begin{code}
 879 showRdrName :: RdrName -> String
 880 showRdrName r = showSDoc (ppr r)
 881
 882 parseError :: String -> P a
 883 parseError s =
 884   getSrcLocP `thenP` \ loc ->
 885   failMsgP (hcat [ppr loc, text ": ", text s])
 886 \end{code}
 887