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         --  Check that the name space is correct!
 523     chk (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = returnP (IfaceTyVar tv k)
 524     chk (HsTyVar tv)               | isRdrTyVar tv = returnP (UserTyVar tv)
 525     chk other                      = parseError "Type found where type variable expected"
 526
 527 checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar])
 528 -- The header of a type or class decl should look like
 529 --      (C a, D b) => T a b
 530 -- or   T a b
 531 -- or   a + b
 532 -- etc
 533 checkTyClHdr ty
 534   = go ty []
 535   where
 536     go (HsTyVar tc)    acc
 537         | not (isRdrTyVar tc) = checkTyVars acc         `thenP` \ tvs ->
 538                                 returnP (tc, tvs)
 539     go (HsOpTy t1 (HsTyOp tc) t2) acc
 540                               = checkTyVars (t1:t2:acc) `thenP` \ tvs ->
 541                                 returnP (tc, tvs)
 542     go (HsParTy ty)    acc    = go ty acc
 543     go (HsAppTy t1 t2) acc    = go t1 (t2:acc)
 544     go other           acc    = parseError "Malformed LHS to type of class declaration"
 545
 546 checkContext :: RdrNameHsType -> P RdrNameContext
 547 checkContext (HsTupleTy _ ts)   -- (Eq a, Ord b) shows up as a tuple type
 548   = mapP checkPred ts
 549
 550 checkContext (HsParTy ty)       -- to be sure HsParTy doesn't get into the way
 551   = checkContext ty
 552
 553 checkContext (HsTyVar t)        -- Empty context shows up as a unit type ()
 554   | t == getRdrName unitTyCon = returnP []
 555
 556 checkContext t
 557   = checkPred t `thenP` \p ->
 558     returnP [p]
 559
 560 checkPred :: RdrNameHsType -> P (HsPred RdrName)
 561 -- Watch out.. in ...deriving( Show )... we use checkPred on
 562 -- the list of partially applied predicates in the deriving,
 563 -- so there can be zero args.
 564 checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty)
 565 checkPred ty
 566   = go ty []
 567   where
 568     go (HsTyVar t) args   | not (isRdrTyVar t)
 569                           = returnP (HsClassP t args)
 570     go (HsAppTy l r) args = go l (r:args)
 571     go (HsParTy t)   args = go t args
 572     go _             _    = parseError "Illegal class assertion"
 573
 574 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
 575 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
 576         = returnP (mkHsDictTy t args)
 577 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
 578 checkDictTy (HsParTy t)   args = checkDictTy t args
 579 checkDictTy _ _ = parseError "Malformed context in instance header"
 580
 581
 582 ---------------------------------------------------------------------------
 583 -- Checking statements in a do-expression
 584 --      We parse   do { e1 ; e2 ; }
 585 --      as [ExprStmt e1, ExprStmt e2]
 586 -- checkDo (a) checks that the last thing is an ExprStmt
 587 --         (b) transforms it to a ResultStmt
 588 -- same comments apply for mdo as well
 589
 590 checkDo  = checkDoMDo "a " "'do'"
 591 checkMDo = checkDoMDo "an " "'mdo'"
 592
 593 checkDoMDo _   nm []               = parseError $ "Empty " ++ nm ++ " construct"
 594 checkDoMDo _   _  [ExprStmt e _ l] = returnP [ResultStmt e l]
 595 checkDoMDo pre nm [s]              = parseError $ "The last statement in " ++ pre ++ nm ++ " construct must be an expression"
 596 checkDoMDo pre nm (s:ss)           = checkDoMDo pre nm ss       `thenP` \ ss' ->
 597                                      returnP (s:ss')
 598
 599 ---------------------------------------------------------------------------
 600 -- Checking Patterns.
 601
 602 -- We parse patterns as expressions and check for valid patterns below,
 603 -- converting the expression into a pattern at the same time.
 604
 605 checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
 606 checkPattern loc e = setSrcLocP loc (checkPat e [])
 607
 608 checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
 609 checkPatterns loc es = mapP (checkPattern loc) es
 610
 611 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
 612 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c (PrefixCon args))
 613 checkPat (HsApp f x) args =
 614         checkPat x [] `thenP` \x ->
 615         checkPat f (x:args)
 616 checkPat e [] = case e of
 617         EWildPat            -> returnP (WildPat placeHolderType)
 618         HsVar x | isQual x  -> parseError ("Qualified variable in pattern: " ++ showRdrName x)
 619                 | otherwise -> returnP (VarPat x)
 620         HsLit l            -> returnP (LitPat l)
 621         HsOverLit l        -> returnP (NPatIn l Nothing)
 622         ELazyPat e         -> checkPat e [] `thenP` (returnP . LazyPat)
 623         EAsPat n e         -> checkPat e [] `thenP` (returnP . AsPat n)
 624         ExprWithTySig e t  -> checkPat e [] `thenP` \e ->
 625                               -- Pattern signatures are parsed as sigtypes,
 626                               -- but they aren't explicit forall points.  Hence
 627                               -- we have to remove the implicit forall here.
 628                               let t' = case t of
 629                                           HsForAllTy Nothing [] ty -> ty
 630                                           other -> other
 631                               in
 632                               returnP (SigPatIn e t')
 633
 634         -- Translate out NegApps of literals in patterns. We negate
 635         -- the Integer here, and add back the call to 'negate' when
 636         -- we typecheck the pattern.
 637         -- NB. Negative *primitive* literals are already handled by
 638         --     RdrHsSyn.mkHsNegApp
 639         NegApp (HsOverLit lit) neg -> returnP (NPatIn lit (Just neg))
 640
 641         OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
 642                            | plus == plus_RDR
 643                            -> returnP (mkNPlusKPat n lit)
 644                            where
 645                               plus_RDR = mkUnqual varName FSLIT("+")    -- Hack
 646
 647         OpApp l op fix r   -> checkPat l [] `thenP` \l ->
 648                               checkPat r [] `thenP` \r ->
 649                               case op of
 650                                  HsVar c | isDataOcc (rdrNameOcc c)
 651                                         -> returnP (ConPatIn c (InfixCon l r))
 652                                  _ -> patFail
 653
 654         HsPar e            -> checkPat e [] `thenP` (returnP . ParPat)
 655         ExplicitList _ es  -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 656                               returnP (ListPat ps placeHolderType)
 657         ExplicitPArr _ es  -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 658                               returnP (PArrPat ps placeHolderType)
 659
 660         ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 661                               returnP (TuplePat ps b)
 662
 663         RecordCon c fs     -> mapP checkPatField fs `thenP` \fs ->
 664                               returnP (ConPatIn c (RecCon fs))
 665 -- Generics
 666         HsType ty          -> returnP (TypePat ty)
 667         _                  -> patFail
 668
 669 checkPat _ _ = patFail
 670
 671 checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat)
 672 checkPatField (n,e) = checkPat e [] `thenP` \p ->
 673                       returnP (n,p)
 674
 675 patFail = parseError "Parse error in pattern"
 676
 677
 678 ---------------------------------------------------------------------------
 679 -- Check Equation Syntax
 680
 681 checkValDef
 682         :: RdrNameHsExpr
 683         -> Maybe RdrNameHsType
 684         -> RdrNameGRHSs
 685         -> SrcLoc
 686         -> P RdrBinding
 687
 688 checkValDef lhs opt_sig grhss loc
 689  = case isFunLhs lhs [] of
 690            Just (f,inf,es)
 691              | isQual f
 692              -> parseError ("Qualified name in function definition: "  ++ showRdrName f)
 693              | otherwise
 694              -> checkPatterns loc es `thenP` \ps ->
 695                 returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
 696
 697            Nothing ->
 698                 checkPattern loc lhs `thenP` \lhs ->
 699                 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
 700
 701 checkValSig
 702         :: RdrNameHsExpr
 703         -> RdrNameHsType
 704         -> SrcLoc
 705         -> P RdrBinding
 706 checkValSig (HsVar v) ty loc | isUnqual v = returnP (RdrHsDecl (SigD (Sig v ty loc)))
 707 checkValSig other     ty loc = parseError "Type signature given for an expression"
 708
 709 mkSigDecls :: [Sig RdrName] -> RdrBinding
 710 mkSigDecls sigs = RdrBindings [RdrHsDecl (SigD sig) | sig <- sigs]
 711
 712
 713 -- A variable binding is parsed as an RdrNameFunMonoBind.
 714 -- See comments with HsBinds.MonoBinds
 715
 716 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
 717 isFunLhs (OpApp l (HsVar op) fix r) es  | not (isRdrDataCon op)
 718                                 = Just (op, True, (l:r:es))
 719                                         | otherwise
 720                                 = case isFunLhs l es of
 721                                     Just (op', True, j : k : es') ->
 722                                       Just (op', True, j : OpApp k (HsVar op) fix r : es')
 723                                     _ -> Nothing
 724 isFunLhs (HsVar f) es | not (isRdrDataCon f)
 725                                 = Just (f,False,es)
 726 isFunLhs (HsApp f e) es         = isFunLhs f (e:es)
 727 isFunLhs (HsPar e)   es@(_:_)   = isFunLhs e es
 728 isFunLhs _ _                    = Nothing
 729
 730 ---------------------------------------------------------------------------
 731 -- Miscellaneous utilities
 732
 733 checkPrecP :: Int -> P Int
 734 checkPrecP i | 0 <= i && i <= maxPrecedence = returnP i
 735              | otherwise                    = parseError "Precedence out of range"
 736
 737 mkRecConstrOrUpdate
 738         :: RdrNameHsExpr
 739         -> RdrNameHsRecordBinds
 740         -> P RdrNameHsExpr
 741
 742 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
 743   = returnP (RecordCon c fs)
 744 mkRecConstrOrUpdate exp fs@(_:_)
 745   = returnP (RecordUpd exp fs)
 746 mkRecConstrOrUpdate _ _
 747   = parseError "Empty record update"
 748
 749 -----------------------------------------------------------------------------
 750 -- utilities for foreign declarations
 751
 752 -- supported calling conventions
 753 --
 754 data CallConv = CCall  CCallConv        -- ccall or stdcall
 755               | DNCall                  -- .NET
 756
 757 -- construct a foreign import declaration
 758 --
 759 mkImport :: CallConv
 760          -> Safety
 761          -> (FastString, RdrName, RdrNameHsType)
 762          -> SrcLoc
 763          -> P RdrNameHsDecl
 764 mkImport (CCall  cconv) safety (entity, v, ty) loc =
 765   parseCImport entity cconv safety v                     `thenP` \importSpec ->
 766   returnP $ ForD (ForeignImport v ty importSpec                     False loc)
 767 mkImport (DNCall      ) _      (entity, v, ty) loc =
 768   returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc)
 769
 770 -- parse the entity string of a foreign import declaration for the `ccall' or
 771 -- `stdcall' calling convention'
 772 --
 773 parseCImport :: FastString
 774              -> CCallConv
 775              -> Safety
 776              -> RdrName
 777              -> P ForeignImport
 778 parseCImport entity cconv safety v
 779   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
 780   | entity == FSLIT ("dynamic") =
 781     returnP $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
 782   | entity == FSLIT ("wrapper") =
 783     returnP $ CImport cconv safety nilFS nilFS CWrapper
 784   | otherwise                  = parse0 (unpackFS entity)
 785     where
 786       -- using the static keyword?
 787       parse0 (' ':                    rest) = parse0 rest
 788       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
 789       parse0                          rest  = parse1 rest
 790       -- check for header file name
 791       parse1     ""               = parse4 ""    nilFS        False nilFS
 792       parse1     (' ':rest)       = parse1 rest
 793       parse1 str@('&':_   )       = parse2 str   nilFS
 794       parse1 str@('[':_   )       = parse3 str   nilFS        False
 795       parse1 str
 796         | ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
 797         | otherwise               = parse4 str   nilFS        False nilFS
 798         where
 799           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
 800       -- check for address operator (indicating a label import)
 801       parse2     ""         header = parse4 ""   header False nilFS
 802       parse2     (' ':rest) header = parse2 rest header
 803       parse2     ('&':rest) header = parse3 rest header True
 804       parse2 str@('[':_   ) header = parse3 str  header False
 805       parse2 str            header = parse4 str  header False nilFS
 806       -- check for library object name
 807       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
 808       parse3 ('[':rest) header isLbl =
 809         case break (== ']') rest of
 810           (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
 811           _                         -> parseError "Missing ']' in entity"
 812       parse3 str        header isLbl = parse4 str  header isLbl nilFS
 813       -- check for name of C function
 814       parse4 ""         header isLbl lib = build (mkExtName v) header isLbl lib
 815       parse4 (' ':rest) header isLbl lib = parse4 rest         header isLbl lib
 816       parse4 str        header isLbl lib
 817         | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
 818         | otherwise                      = parseError "Malformed entity string"
 819         where
 820           (first, rest) = break (== ' ') str
 821       --
 822       build cid header False lib = returnP $
 823         CImport cconv safety header lib (CFunction (StaticTarget cid))
 824       build cid header True  lib = returnP $
 825         CImport cconv safety header lib (CLabel                  cid )
 826
 827 -- construct a foreign export declaration
 828 --
 829 mkExport :: CallConv
 830          -> (FastString, RdrName, RdrNameHsType)
 831          -> SrcLoc
 832          -> P RdrNameHsDecl
 833 mkExport (CCall  cconv) (entity, v, ty) loc = returnP $
 834   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
 835   where
 836     entity' | nullFastString entity = mkExtName v
 837             | otherwise             = entity
 838 mkExport DNCall (entity, v, ty) loc =
 839   parseError "Foreign export is not yet supported for .NET"
 840
 841 -- Supplying the ext_name in a foreign decl is optional; if it
 842 -- isn't there, the Haskell name is assumed. Note that no transformation
 843 -- of the Haskell name is then performed, so if you foreign export (++),
 844 -- it's external name will be "++". Too bad; it's important because we don't
 845 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 846 -- (This is why we use occNameUserString.)
 847 --
 848 mkExtName :: RdrName -> CLabelString
 849 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
 850
 851 -- ---------------------------------------------------------------------------
 852 -- Make the export list for an interface
 853
 854 mkIfaceExports :: [RdrNameTyClDecl] -> [RdrAvailInfo]
 855 mkIfaceExports decls = map getExport decls
 856   where getExport d = case d of
 857                         TyData{}    -> tc_export
 858                         ClassDecl{} -> tc_export
 859                         _other      -> var_export
 860           where
 861                 tc_export  = AvailTC (rdrNameOcc (tcdName d))
 862                                 (map (rdrNameOcc.fst) (tyClDeclNames d))
 863                 var_export = Avail (rdrNameOcc (tcdName d))
 864 \end{code}
 865
 866
 867 -----------------------------------------------------------------------------
 868 -- Misc utils
 869
 870 \begin{code}
 871 showRdrName :: RdrName -> String
 872 showRdrName r = showSDoc (ppr r)
 873
 874 parseError :: String -> P a
 875 parseError s =
 876   getSrcLocP `thenP` \ loc ->
 877   failMsgP (hcat [ppr loc, text ": ", text s])
 878 \end{code}
 879