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