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 = HsSplice unqualSplice e
 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 has_args ((Match args _ _) : _) = not (null args)
 405         -- Don't group together FunMonoBinds if they have
 406         -- no arguments.  This is necessary now that variable bindings
 407         -- with no arguments are now treated as FunMonoBinds rather
 408         -- than pattern bindings (tests/rename/should_fail/rnfail002).
 409 \end{code}
 410
 411 \begin{code}
 412 emptyGroup = HsGroup { hs_valds = MonoBind EmptyMonoBinds [] Recursive,
 413                         -- The renamer adds structure to the bindings;
 414                         -- they start life as a single giant MonoBinds
 415                        hs_tyclds = [], hs_instds = [],
 416                        hs_fixds = [], hs_defds = [], hs_fords = [],
 417                        hs_depds = [] ,hs_ruleds = [], hs_coreds = [] }
 418
 419 findSplice :: [HsDecl a] -> (HsGroup a, Maybe (HsExpr a, [HsDecl a]))
 420 findSplice ds = add emptyGroup ds
 421
 422 mkGroup :: [HsDecl a] -> HsGroup a
 423 mkGroup ds = addImpDecls emptyGroup ds
 424
 425 addImpDecls :: HsGroup a -> [HsDecl a] -> HsGroup a
 426 -- The decls are imported, and should not have a splice
 427 addImpDecls group decls = case add group decls of
 428                                 (group', Nothing) -> group'
 429                                 other             -> panic "addImpDecls"
 430
 431 add :: HsGroup a -> [HsDecl a] -> (HsGroup a, Maybe (HsExpr a, [HsDecl a]))
 432         -- This stuff reverses the declarations (again) but it doesn't matter
 433
 434 -- Base cases
 435 add gp []               = (gp, Nothing)
 436 add gp (SpliceD e : ds) = (gp, Just (e, ds))
 437
 438 -- Class declarations: pull out the fixity signatures to the top
 439 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) (TyClD d : ds)
 440         | isClassDecl d = add (gp { hs_tyclds = d : ts,
 441                                     hs_fixds  = [f | FixSig f <- tcdSigs d] }) ds
 442         | otherwise     = add (gp { hs_tyclds = d : ts }) ds
 443
 444 -- Signatures: fixity sigs go a different place than all others
 445 add gp@(HsGroup {hs_fixds = ts}) (SigD (FixSig f) : ds) = add (gp {hs_fixds = f : ts}) ds
 446 add gp@(HsGroup {hs_valds = ts}) (SigD d : ds)          = add (gp {hs_valds = add_sig d ts}) ds
 447
 448 -- Value declarations: use add_bind
 449 add gp@(HsGroup {hs_valds  = ts}) (ValD d : ds) = add (gp { hs_valds = add_bind d ts }) ds
 450
 451 -- The rest are routine
 452 add gp@(HsGroup {hs_instds = ts}) (InstD d : ds)   = add (gp { hs_instds = d : ts }) ds
 453 add gp@(HsGroup {hs_defds  = ts}) (DefD d : ds)    = add (gp { hs_defds = d : ts }) ds
 454 add gp@(HsGroup {hs_fords  = ts}) (ForD d : ds)    = add (gp { hs_fords = d : ts }) ds
 455 add gp@(HsGroup {hs_depds  = ts}) (DeprecD d : ds) = add (gp { hs_depds = d : ts }) ds
 456 add gp@(HsGroup {hs_ruleds  = ts})(RuleD d : ds)   = add (gp { hs_ruleds = d : ts }) ds
 457 add gp@(HsGroup {hs_coreds  = ts})(CoreD d : ds)   = add (gp { hs_coreds = d : ts }) ds
 458
 459 add_bind b (MonoBind bs sigs r) = MonoBind (bs `AndMonoBinds` b) sigs r
 460 add_sig  s (MonoBind bs sigs r) = MonoBind bs                (s:sigs) r
 461 \end{code}
 462
 463 %************************************************************************
 464 %*                                                                      *
 465 \subsection[PrefixToHS-utils]{Utilities for conversion}
 466 %*                                                                      *
 467 %************************************************************************
 468
 469
 470 \begin{code}
 471 -----------------------------------------------------------------------------
 472 -- mkPrefixCon
 473
 474 -- When parsing data declarations, we sometimes inadvertently parse
 475 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
 476 -- This function splits up the type application, adds any pending
 477 -- arguments, and converts the type constructor back into a data constructor.
 478
 479 mkPrefixCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
 480
 481 mkPrefixCon ty tys
 482  = split ty tys
 483  where
 484    split (HsAppTy t u)  ts = split t (unbangedType u : ts)
 485    split (HsTyVar tc)   ts = tyConToDataCon tc  `thenP` \ data_con ->
 486                              returnP (data_con, PrefixCon ts)
 487    split _               _ = parseError "Illegal data/newtype declaration"
 488
 489 mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
 490 mkRecCon con fields
 491   = tyConToDataCon con  `thenP` \ data_con ->
 492     returnP (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
 493
 494 tyConToDataCon :: RdrName -> P RdrName
 495 tyConToDataCon tc
 496   | isTcOcc (rdrNameOcc tc)
 497   = returnP (setRdrNameSpace tc dataName)
 498   | otherwise
 499   = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
 500
 501 ----------------------------------------------------------------------------
 502 -- Various Syntactic Checks
 503
 504 checkInstType :: RdrNameHsType -> P RdrNameHsType
 505 checkInstType t
 506   = case t of
 507         HsForAllTy tvs ctxt ty ->
 508                 checkDictTy ty [] `thenP` \ dict_ty ->
 509                 returnP (HsForAllTy tvs ctxt dict_ty)
 510
 511         HsParTy ty -> checkInstType ty
 512
 513         ty ->   checkDictTy ty [] `thenP` \ dict_ty->
 514                 returnP (HsForAllTy Nothing [] dict_ty)
 515
 516 checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar]
 517 checkTyVars tvs = mapP chk tvs
 518                 where
 519                   chk (HsKindSig (HsTyVar tv) k) = returnP (IfaceTyVar tv k)
 520                   chk (HsTyVar tv)               = returnP (UserTyVar tv)
 521                   chk other                      = parseError "Type found where type variable expected"
 522
 523 checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar])
 524 -- The header of a type or class decl should look like
 525 --      (C a, D b) => T a b
 526 -- or   T a b
 527 -- or   a + b
 528 -- etc
 529 checkTyClHdr ty
 530   = go ty []
 531   where
 532     go (HsTyVar tc)    acc
 533         | not (isRdrTyVar tc) = checkTyVars acc         `thenP` \ tvs ->
 534                                 returnP (tc, tvs)
 535     go (HsOpTy t1 (HsTyOp tc) t2) acc
 536                               = checkTyVars (t1:t2:acc) `thenP` \ tvs ->
 537                                 returnP (tc, tvs)
 538     go (HsParTy ty)    acc    = go ty acc
 539     go (HsAppTy t1 t2) acc    = go t1 (t2:acc)
 540     go other           acc    = parseError "Malformed LHS to type of class declaration"
 541
 542 checkContext :: RdrNameHsType -> P RdrNameContext
 543 checkContext (HsTupleTy _ ts)   -- (Eq a, Ord b) shows up as a tuple type
 544   = mapP checkPred ts
 545
 546 checkContext (HsParTy ty)       -- to be sure HsParTy doesn't get into the way
 547   = checkContext ty
 548
 549 checkContext (HsTyVar t)        -- Empty context shows up as a unit type ()
 550   | t == getRdrName unitTyCon = returnP []
 551
 552 checkContext t
 553   = checkPred t `thenP` \p ->
 554     returnP [p]
 555
 556 checkPred :: RdrNameHsType -> P (HsPred RdrName)
 557 -- Watch out.. in ...deriving( Show )... we use checkPred on
 558 -- the list of partially applied predicates in the deriving,
 559 -- so there can be zero args.
 560 checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty)
 561 checkPred ty
 562   = go ty []
 563   where
 564     go (HsTyVar t) args   | not (isRdrTyVar t)
 565                           = returnP (HsClassP t args)
 566     go (HsAppTy l r) args = go l (r:args)
 567     go (HsParTy t)   args = go t args
 568     go _             _    = parseError "Illegal class assertion"
 569
 570 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
 571 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
 572         = returnP (mkHsDictTy t args)
 573 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
 574 checkDictTy (HsParTy t)   args = checkDictTy t args
 575 checkDictTy _ _ = parseError "Malformed context in instance header"
 576
 577
 578 ---------------------------------------------------------------------------
 579 -- Checking statements in a do-expression
 580 --      We parse   do { e1 ; e2 ; }
 581 --      as [ExprStmt e1, ExprStmt e2]
 582 -- checkDo (a) checks that the last thing is an ExprStmt
 583 --         (b) transforms it to a ResultStmt
 584 -- same comments apply for mdo as well
 585
 586 checkDo  = checkDoMDo "a " "'do'"
 587 checkMDo = checkDoMDo "an " "'mdo'"
 588
 589 checkDoMDo _   nm []               = parseError $ "Empty " ++ nm ++ " construct"
 590 checkDoMDo _   _  [ExprStmt e _ l] = returnP [ResultStmt e l]
 591 checkDoMDo pre nm [s]              = parseError $ "The last statement in " ++ pre ++ nm ++ " construct must be an expression"
 592 checkDoMDo pre nm (s:ss)           = checkDoMDo pre nm ss       `thenP` \ ss' ->
 593                                      returnP (s:ss')
 594
 595 ---------------------------------------------------------------------------
 596 -- Checking Patterns.
 597
 598 -- We parse patterns as expressions and check for valid patterns below,
 599 -- converting the expression into a pattern at the same time.
 600
 601 checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
 602 checkPattern loc e = setSrcLocP loc (checkPat e [])
 603
 604 checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
 605 checkPatterns loc es = mapP (checkPattern loc) es
 606
 607 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
 608 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c (PrefixCon args))
 609 checkPat (HsApp f x) args =
 610         checkPat x [] `thenP` \x ->
 611         checkPat f (x:args)
 612 checkPat e [] = case e of
 613         EWildPat           -> returnP (WildPat placeHolderType)
 614         HsVar x            -> returnP (VarPat x)
 615         HsLit l            -> returnP (LitPat l)
 616         HsOverLit l        -> returnP (NPatIn l Nothing)
 617         ELazyPat e         -> checkPat e [] `thenP` (returnP . LazyPat)
 618         EAsPat n e         -> checkPat e [] `thenP` (returnP . AsPat n)
 619         ExprWithTySig e t  -> checkPat e [] `thenP` \e ->
 620                               -- Pattern signatures are parsed as sigtypes,
 621                               -- but they aren't explicit forall points.  Hence
 622                               -- we have to remove the implicit forall here.
 623                               let t' = case t of
 624                                           HsForAllTy Nothing [] ty -> ty
 625                                           other -> other
 626                               in
 627                               returnP (SigPatIn e t')
 628
 629         -- Translate out NegApps of literals in patterns. We negate
 630         -- the Integer here, and add back the call to 'negate' when
 631         -- we typecheck the pattern.
 632         -- NB. Negative *primitive* literals are already handled by
 633         --     RdrHsSyn.mkHsNegApp
 634         NegApp (HsOverLit lit) neg -> returnP (NPatIn lit (Just neg))
 635
 636         OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
 637                            | plus == plus_RDR
 638                            -> returnP (mkNPlusKPat n lit)
 639                            where
 640                               plus_RDR = mkUnqual varName FSLIT("+")    -- Hack
 641
 642         OpApp l op fix r   -> checkPat l [] `thenP` \l ->
 643                               checkPat r [] `thenP` \r ->
 644                               case op of
 645                                  HsVar c | isDataOcc (rdrNameOcc c)
 646                                         -> returnP (ConPatIn c (InfixCon l r))
 647                                  _ -> patFail
 648
 649         HsPar e            -> checkPat e [] `thenP` (returnP . ParPat)
 650         ExplicitList _ es  -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 651                               returnP (ListPat ps placeHolderType)
 652         ExplicitPArr _ es  -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 653                               returnP (PArrPat ps placeHolderType)
 654
 655         ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 656                               returnP (TuplePat ps b)
 657
 658         RecordCon c fs     -> mapP checkPatField fs `thenP` \fs ->
 659                               returnP (ConPatIn c (RecCon fs))
 660 -- Generics
 661         HsType ty          -> returnP (TypePat ty)
 662         _                  -> patFail
 663
 664 checkPat _ _ = patFail
 665
 666 checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat)
 667 checkPatField (n,e) = checkPat e [] `thenP` \p ->
 668                       returnP (n,p)
 669
 670 patFail = parseError "Parse error in pattern"
 671
 672
 673 ---------------------------------------------------------------------------
 674 -- Check Equation Syntax
 675
 676 checkValDef
 677         :: RdrNameHsExpr
 678         -> Maybe RdrNameHsType
 679         -> RdrNameGRHSs
 680         -> SrcLoc
 681         -> P RdrBinding
 682
 683 checkValDef lhs opt_sig grhss loc
 684  = case isFunLhs lhs [] of
 685            Just (f,inf,es) ->
 686                 checkPatterns loc es `thenP` \ps ->
 687                 returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
 688
 689            Nothing ->
 690                 checkPattern loc lhs `thenP` \lhs ->
 691                 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
 692
 693 checkValSig
 694         :: RdrNameHsExpr
 695         -> RdrNameHsType
 696         -> SrcLoc
 697         -> P RdrBinding
 698 checkValSig (HsVar v) ty loc | isUnqual v = returnP (RdrHsDecl (SigD (Sig v ty loc)))
 699 checkValSig other     ty loc = parseError "Type signature given for an expression"
 700
 701 mkSigDecls :: [Sig RdrName] -> RdrBinding
 702 mkSigDecls sigs = RdrBindings [RdrHsDecl (SigD sig) | sig <- sigs]
 703
 704
 705 -- A variable binding is parsed as an RdrNameFunMonoBind.
 706 -- See comments with HsBinds.MonoBinds
 707
 708 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
 709 isFunLhs (OpApp l (HsVar op) fix r) es  | not (isRdrDataCon op)
 710                                 = Just (op, True, (l:r:es))
 711                                         | otherwise
 712                                 = case isFunLhs l es of
 713                                     Just (op', True, j : k : es') ->
 714                                       Just (op', True, j : OpApp k (HsVar op) fix r : es')
 715                                     _ -> Nothing
 716 isFunLhs (HsVar f) es | not (isRdrDataCon f)
 717                                 = Just (f,False,es)
 718 isFunLhs (HsApp f e) es         = isFunLhs f (e:es)
 719 isFunLhs (HsPar e)   es@(_:_)   = isFunLhs e es
 720 isFunLhs _ _                    = Nothing
 721
 722 ---------------------------------------------------------------------------
 723 -- Miscellaneous utilities
 724
 725 checkPrecP :: Int -> P Int
 726 checkPrecP i | 0 <= i && i <= maxPrecedence = returnP i
 727              | otherwise                    = parseError "Precedence out of range"
 728
 729 mkRecConstrOrUpdate
 730         :: RdrNameHsExpr
 731         -> RdrNameHsRecordBinds
 732         -> P RdrNameHsExpr
 733
 734 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
 735   = returnP (RecordCon c fs)
 736 mkRecConstrOrUpdate exp fs@(_:_)
 737   = returnP (RecordUpd exp fs)
 738 mkRecConstrOrUpdate _ _
 739   = parseError "Empty record update"
 740
 741 -----------------------------------------------------------------------------
 742 -- utilities for foreign declarations
 743
 744 -- supported calling conventions
 745 --
 746 data CallConv = CCall  CCallConv        -- ccall or stdcall
 747               | DNCall                  -- .NET
 748
 749 -- construct a foreign import declaration
 750 --
 751 mkImport :: CallConv
 752          -> Safety
 753          -> (FastString, RdrName, RdrNameHsType)
 754          -> SrcLoc
 755          -> P RdrNameHsDecl
 756 mkImport (CCall  cconv) safety (entity, v, ty) loc =
 757   parseCImport entity cconv safety v                     `thenP` \importSpec ->
 758   returnP $ ForD (ForeignImport v ty importSpec                     False loc)
 759 mkImport (DNCall      ) _      (entity, v, ty) loc =
 760   returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc)
 761
 762 -- parse the entity string of a foreign import declaration for the `ccall' or
 763 -- `stdcall' calling convention'
 764 --
 765 parseCImport :: FastString
 766              -> CCallConv
 767              -> Safety
 768              -> RdrName
 769              -> P ForeignImport
 770 parseCImport entity cconv safety v
 771   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
 772   | entity == FSLIT ("dynamic") =
 773     returnP $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
 774   | entity == FSLIT ("wrapper") =
 775     returnP $ CImport cconv safety nilFS nilFS CWrapper
 776   | otherwise                  = parse0 (unpackFS entity)
 777     where
 778       -- using the static keyword?
 779       parse0 (' ':                    rest) = parse0 rest
 780       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
 781       parse0                          rest  = parse1 rest
 782       -- check for header file name
 783       parse1     ""               = parse4 ""    nilFS        False nilFS
 784       parse1     (' ':rest)       = parse1 rest
 785       parse1 str@('&':_   )       = parse2 str   nilFS
 786       parse1 str@('[':_   )       = parse3 str   nilFS        False
 787       parse1 str
 788         | ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
 789         | otherwise               = parse4 str   nilFS        False nilFS
 790         where
 791           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
 792       -- check for address operator (indicating a label import)
 793       parse2     ""         header = parse4 ""   header False nilFS
 794       parse2     (' ':rest) header = parse2 rest header
 795       parse2     ('&':rest) header = parse3 rest header True
 796       parse2 str@('[':_   ) header = parse3 str  header False
 797       parse2 str            header = parse4 str  header False nilFS
 798       -- check for library object name
 799       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
 800       parse3 ('[':rest) header isLbl =
 801         case break (== ']') rest of
 802           (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
 803           _                         -> parseError "Missing ']' in entity"
 804       parse3 str        header isLbl = parse4 str  header isLbl nilFS
 805       -- check for name of C function
 806       parse4 ""         header isLbl lib = build (mkExtName v) header isLbl lib
 807       parse4 (' ':rest) header isLbl lib = parse4 rest         header isLbl lib
 808       parse4 str        header isLbl lib
 809         | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
 810         | otherwise                      = parseError "Malformed entity string"
 811         where
 812           (first, rest) = break (== ' ') str
 813       --
 814       build cid header False lib = returnP $
 815         CImport cconv safety header lib (CFunction (StaticTarget cid))
 816       build cid header True  lib = returnP $
 817         CImport cconv safety header lib (CLabel                  cid )
 818
 819 -- construct a foreign export declaration
 820 --
 821 mkExport :: CallConv
 822          -> (FastString, RdrName, RdrNameHsType)
 823          -> SrcLoc
 824          -> P RdrNameHsDecl
 825 mkExport (CCall  cconv) (entity, v, ty) loc = returnP $
 826   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
 827   where
 828     entity' | nullFastString entity = mkExtName v
 829             | otherwise             = entity
 830 mkExport DNCall (entity, v, ty) loc =
 831   parseError "Foreign export is not yet supported for .NET"
 832
 833 -- Supplying the ext_name in a foreign decl is optional; if it
 834 -- isn't there, the Haskell name is assumed. Note that no transformation
 835 -- of the Haskell name is then performed, so if you foreign export (++),
 836 -- it's external name will be "++". Too bad; it's important because we don't
 837 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 838 -- (This is why we use occNameUserString.)
 839 --
 840 mkExtName :: RdrName -> CLabelString
 841 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
 842
 843 -- ---------------------------------------------------------------------------
 844 -- Make the export list for an interface
 845
 846 mkIfaceExports :: [RdrNameTyClDecl] -> [RdrAvailInfo]
 847 mkIfaceExports decls = map getExport decls
 848   where getExport d = case d of
 849                         TyData{}    -> tc_export
 850                         ClassDecl{} -> tc_export
 851                         _other      -> var_export
 852           where
 853                 tc_export  = AvailTC (rdrNameOcc (tcdName d))
 854                                 (map (rdrNameOcc.fst) (tyClDeclNames d))
 855                 var_export = Avail (rdrNameOcc (tcdName d))
 856 \end{code}
 857
 858
 859 -----------------------------------------------------------------------------
 860 -- Misc utils
 861
 862 \begin{code}
 863 parseError :: String -> P a
 864 parseError s =
 865   getSrcLocP `thenP` \ loc ->
 866   failMsgP (hcat [ppr loc, text ": ", text s])
 867 \end{code}
 868