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