ghc/compiler/parser/RdrHsSyn.lhs

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