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