ghc/compiler/parser/RdrHsSyn.lhs

   1 %
   2 % (c) The University of Glasgow, 1996-2003
   3
   4 Functions over HsSyn specialised to RdrName.
   5
   6 \begin{code}
   7 module RdrHsSyn (
   8         extractHsTyRdrTyVars,
   9         extractHsRhoRdrTyVars, extractGenericPatTyVars,
  10
  11         mkHsOpApp, mkClassDecl,
  12         mkHsNegApp, mkHsIntegral, mkHsFractional,
  13         mkHsDo, mkHsSplice,
  14         mkTyData, mkPrefixCon, mkRecCon,
  15         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
  16         mkBootIface,
  17
  18         cvBindGroup,
  19         cvBindsAndSigs,
  20         cvTopDecls,
  21         findSplice, mkGroup,
  22
  23         -- Stuff to do with Foreign declarations
  24         , CallConv(..)
  25         , mkImport            -- CallConv -> Safety
  26                               -- -> (FastString, RdrName, RdrNameHsType)
  27                               -- -> P RdrNameHsDecl
  28         , mkExport            -- CallConv
  29                               -- -> (FastString, RdrName, RdrNameHsType)
  30                               -- -> P RdrNameHsDecl
  31         , mkExtName           -- RdrName -> CLabelString
  32
  33         -- Bunch of functions in the parser monad for
  34         -- checking and constructing values
  35         , checkPrecP          -- Int -> P Int
  36         , checkContext        -- HsType -> P HsContext
  37         , checkPred           -- HsType -> P HsPred
  38         , checkTyClHdr        -- HsType -> (name,[tyvar])
  39         , checkInstType       -- HsType -> P HsType
  40         , checkPattern        -- HsExp -> P HsPat
  41         , checkPatterns       -- SrcLoc -> [HsExp] -> P [HsPat]
  42         , checkDo             -- [Stmt] -> P [Stmt]
  43         , checkMDo            -- [Stmt] -> P [Stmt]
  44         , checkValDef         -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  45         , checkValSig         -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  46         , parseError          -- String -> Pa
  47     ) where
  48
  49 #include "HsVersions.h"
  50
  51 import HsSyn            -- Lots of it
  52 import IfaceType
  53 import HscTypes         ( ModIface(..), emptyModIface, mkIfaceVerCache )
  54 import IfaceSyn         ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..), IfaceConDecls(..) )
  55 import RdrName          ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
  56                           isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
  57                           setRdrNameSpace, rdrNameModule )
  58 import BasicTypes       ( RecFlag(..), mapIPName, maxPrecedence, initialVersion )
  59 import Lexer            ( P, failSpanMsgP )
  60 import Kind             ( liftedTypeKind )
  61 import HscTypes         ( GenAvailInfo(..) )
  62 import TysWiredIn       ( unitTyCon )
  63 import ForeignCall      ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
  64                           DNCallSpec(..), DNKind(..), CLabelString )
  65 import OccName          ( OccName, srcDataName, varName, isDataOcc, isTcOcc,
  66                           occNameUserString, isValOcc )
  67 import BasicTypes       ( initialVersion, StrictnessMark(..) )
  68 import Module           ( ModuleName )
  69 import SrcLoc
  70 import CmdLineOpts      ( opt_InPackage )
  71 import OrdList          ( OrdList, fromOL )
  72 import Bag              ( Bag, emptyBag, snocBag, consBag, foldrBag )
  73 import Outputable
  74 import FastString
  75 import Panic
  76
  77 import List             ( isSuffixOf, nubBy )
  78 \end{code}
  79
  80
  81 %************************************************************************
  82 %*                                                                      *
  83 \subsection{A few functions over HsSyn at RdrName}
  84 %*                                                                    *
  85 %************************************************************************
  86
  87 extractHsTyRdrNames finds the free variables of a HsType
  88 It's used when making the for-alls explicit.
  89
  90 \begin{code}
  91 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
  92 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
  93
  94 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
  95 -- This one takes the context and tau-part of a
  96 -- sigma type and returns their free type variables
  97 extractHsRhoRdrTyVars ctxt ty
  98  = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
  99
 100 extract_lctxt ctxt acc = foldr (extract_pred.unLoc) acc (unLoc ctxt)
 101
 102 extract_pred (HsClassP cls tys) acc     = foldr extract_lty acc tys
 103 extract_pred (HsIParam n ty) acc        = extract_lty ty acc
 104
 105 extract_lty (L loc (HsTyVar tv)) acc
 106   | isRdrTyVar tv = L loc tv : acc
 107   | otherwise = acc
 108 extract_lty ty acc = extract_ty (unLoc ty) acc
 109
 110 extract_ty (HsAppTy ty1 ty2)         acc = extract_lty ty1 (extract_lty ty2 acc)
 111 extract_ty (HsListTy ty)             acc = extract_lty ty acc
 112 extract_ty (HsPArrTy ty)             acc = extract_lty ty acc
 113 extract_ty (HsTupleTy _ tys)         acc = foldr extract_lty acc tys
 114 extract_ty (HsFunTy ty1 ty2)         acc = extract_lty ty1 (extract_lty ty2 acc)
 115 extract_ty (HsPredTy p)              acc = extract_pred p acc
 116 extract_ty (HsOpTy ty1 nam ty2)      acc = extract_lty ty1 (extract_lty ty2 acc)
 117 extract_ty (HsParTy ty)              acc = extract_lty ty acc
 118 extract_ty (HsNumTy num)             acc = acc
 119 extract_ty (HsSpliceTy _)            acc = acc  -- Type splices mention no type variables
 120 extract_ty (HsKindSig ty k)          acc = extract_lty ty acc
 121 extract_ty (HsForAllTy exp [] cx ty) acc = extract_lctxt cx (extract_lty ty acc)
 122 extract_ty (HsForAllTy exp tvs cx ty)
 123                                 acc = (filter ((`notElem` locals) . unLoc) $
 124                                        extract_lctxt cx (extract_lty ty [])) ++ acc
 125                                     where
 126                                       locals = hsLTyVarNames tvs
 127
 128 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
 129 -- Get the type variables out of the type patterns in a bunch of
 130 -- possibly-generic bindings in a class declaration
 131 extractGenericPatTyVars binds
 132   = nubBy eqLocated (foldrBag get [] binds)
 133   where
 134     get (L _ (FunBind _ _ ms)) acc = foldr (get_m.unLoc) acc ms
 135     get other                  acc = acc
 136
 137     get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
 138     get_m other                                    acc = acc
 139 \end{code}
 140
 141
 142 %************************************************************************
 143 %*                                                                      *
 144 \subsection{Construction functions for Rdr stuff}
 145 %*                                                                    *
 146 %************************************************************************
 147
 148 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
 149 by deriving them from the name of the class.  We fill in the names for the
 150 tycon and datacon corresponding to the class, by deriving them from the
 151 name of the class itself.  This saves recording the names in the interface
 152 file (which would be equally good).
 153
 154 Similarly for mkConDecl, mkClassOpSig and default-method names.
 155
 156         *** See "THE NAMING STORY" in HsDecls ****
 157
 158 \begin{code}
 159 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
 160   = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
 161                 tcdFDs = fds,
 162                 tcdSigs = sigs,
 163                 tcdMeths = mbinds
 164                 }
 165
 166 mkTyData new_or_data (context, tname, tyvars) data_cons maybe
 167   = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
 168              tcdTyVars = tyvars,  tcdCons = data_cons,
 169              tcdDerivs = maybe }
 170 \end{code}
 171
 172 \begin{code}
 173 mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
 174 -- RdrName If the type checker sees (negate 3#) it will barf, because negate
 175 -- can't take an unboxed arg.  But that is exactly what it will see when
 176 -- we write "-3#".  So we have to do the negation right now!
 177 mkHsNegApp (L loc e) = f e
 178   where f (HsLit (HsIntPrim i))    = HsLit (HsIntPrim (-i))
 179         f (HsLit (HsFloatPrim i))  = HsLit (HsFloatPrim (-i))
 180         f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
 181         f expr                     = NegApp (L loc e) placeHolderName
 182 \end{code}
 183
 184 %************************************************************************
 185 %*                                                                      *
 186                 Hi-boot files
 187 %*                                                                      *
 188 %************************************************************************
 189
 190 mkBootIface, and its boring helper functions, have two purposes:
 191 a) HsSyn to IfaceSyn.  The parser parses the former, but we're reading
 192         an hi-boot file, and interfaces consist of the latter
 193 b) Convert unqualifed names from the "current module" to qualified Orig
 194    names.  E.g.
 195         module This where
 196          foo :: GHC.Base.Int -> GHC.Base.Int
 197    becomes
 198          This.foo :: GHC.Base.Int -> GHC.Base.Int
 199
 200 It assumes that everything is well kinded, of course.
 201
 202 \begin{code}
 203 mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface
 204 -- Make the ModIface for a hi-boot file
 205 -- The decls are of very limited form
 206 mkBootIface mod decls
 207   = (emptyModIface opt_InPackage mod) {
 208         mi_boot     = True,
 209         mi_exports  = [(mod, map mk_export decls')],
 210         mi_decls    = decls_w_vers,
 211         mi_ver_fn   = mkIfaceVerCache decls_w_vers }
 212   where
 213     decls' = map hsIfaceDecl decls
 214     decls_w_vers = repeat initialVersion `zip` decls'
 215
 216                 -- hi-boot declarations don't (currently)
 217                 -- expose constructors or class methods
 218     mk_export decl | isValOcc occ = Avail occ
 219                    | otherwise    = AvailTC occ [occ]
 220                    where
 221                      occ = ifName decl
 222
 223
 224 hsIfaceDecl :: HsDecl RdrName -> IfaceDecl
 225         -- Change to Iface syntax, and replace unqualified names with
 226         -- qualified Orig names from this module.  Reason: normal
 227         -- iface files have everything fully qualified, so it's convenient
 228         -- for hi-boot files to look the same
 229         --
 230         -- NB: no constructors or class ops to worry about
 231 hsIfaceDecl (SigD (Sig name ty))
 232   = IfaceId { ifName = rdrNameOcc (unLoc name),
 233               ifType = hsIfaceLType ty,
 234               ifIdInfo = NoInfo }
 235
 236 hsIfaceDecl (TyClD decl@(TySynonym {}))
 237   = IfaceSyn { ifName = rdrNameOcc (tcdName decl),
 238                ifTyVars = hsIfaceTvs (tcdTyVars decl),
 239                ifSynRhs = hsIfaceLType (tcdSynRhs decl),
 240                ifVrcs = [] }
 241
 242 hsIfaceDecl (TyClD decl@(TyData {}))
 243   = IfaceData { ifName = rdrNameOcc (tcdName decl),
 244                 ifTyVars = hsIfaceTvs (tcdTyVars decl),
 245                 ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
 246                 ifCons = hsIfaceCons (tcdND decl) (tcdCons decl),
 247                 ifRec = NonRecursive,
 248                 ifVrcs = [], ifGeneric = False }
 249         -- I'm not sure that [] is right for ifVrcs, but
 250         -- since we don't use them I'm not going to fiddle
 251
 252 hsIfaceDecl (TyClD decl@(ClassDecl {}))
 253   = IfaceClass { ifName = rdrNameOcc (tcdName decl),
 254                  ifTyVars = hsIfaceTvs (tcdTyVars decl),
 255                  ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
 256                  ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)),
 257                  ifSigs = [],   -- Is this right??
 258                  ifRec = NonRecursive, ifVrcs = [] }
 259
 260 hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl)
 261
 262 hsIfaceCons :: NewOrData -> [LConDecl RdrName] -> IfaceConDecls
 263 hsIfaceCons DataType [] -- data T a, meaning "constructors unspecified",
 264   = IfAbstractTyCon     -- not "no constructors"
 265
 266 hsIfaceCons DataType cons       -- data type
 267   = IfDataTyCon (map (hsIfaceCon . unLoc) cons)
 268
 269 hsIfaceCons NewType [con]       -- newtype
 270   = IfNewTyCon (hsIfaceCon (unLoc con))
 271
 272
 273 hsIfaceCon :: ConDecl RdrName -> IfaceConDecl
 274 hsIfaceCon (ConDecl lname ex_tvs ex_ctxt details)
 275   = IfaceConDecl (get_occ lname) is_infix
 276                  (hsIfaceTvs ex_tvs)
 277                  (hsIfaceCtxt (unLoc ex_ctxt))
 278                  (map (hsIfaceLType . getBangType       . unLoc) args)
 279                  (map (hsStrictMark . getBangStrictness . unLoc) args)
 280                  flds
 281   where
 282     (is_infix, args, flds) = case details of
 283                                 PrefixCon args -> (False, args, [])
 284                                 InfixCon a1 a2 -> (True, [a1,a2], [])
 285                                 RecCon fs      -> (False, map snd fs, map (get_occ . fst) fs)
 286     get_occ lname = rdrNameOcc (unLoc lname)
 287
 288 hsStrictMark :: HsBang -> StrictnessMark
 289 -- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request
 290 --          but in an hi-boot file it's interpreted as the Truth!
 291 hsStrictMark HsNoBang = NotMarkedStrict
 292 hsStrictMark HsStrict = MarkedStrict
 293 hsStrictMark HsUnbox  = MarkedUnboxed
 294
 295 hsIfaceName rdr_name    -- Qualify unqualifed occurrences
 296                                 -- with the module name
 297   | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
 298   | otherwise         = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
 299
 300 hsIfaceLType :: LHsType RdrName -> IfaceType
 301 hsIfaceLType = hsIfaceType . unLoc
 302
 303 hsIfaceType :: HsType RdrName -> IfaceType
 304 hsIfaceType (HsForAllTy exp tvs cxt ty)
 305   = foldr (IfaceForAllTy . hsIfaceTv) rho tvs'
 306   where
 307     rho = foldr (IfaceFunTy . IfacePredTy . hsIfaceLPred) tau (unLoc cxt)
 308     tau = hsIfaceLType ty
 309     tvs' = case exp of
 310              Explicit -> map unLoc tvs
 311              Implicit -> map (UserTyVar . unLoc) (extractHsRhoRdrTyVars cxt ty)
 312
 313 hsIfaceType ty@(HsTyVar _)     = hs_tc_app ty []
 314 hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty []
 315 hsIfaceType (HsFunTy t1 t2)    = IfaceFunTy (hsIfaceLType t1) (hsIfaceLType t2)
 316 hsIfaceType (HsListTy t)       = IfaceTyConApp IfaceListTc [hsIfaceLType t]
 317 hsIfaceType (HsPArrTy t)       = IfaceTyConApp IfacePArrTc [hsIfaceLType t]
 318 hsIfaceType (HsTupleTy bx ts)  = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
 319 hsIfaceType (HsOpTy t1 tc t2)  = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
 320 hsIfaceType (HsParTy t)        = hsIfaceLType t
 321 hsIfaceType (HsPredTy p)       = IfacePredTy (hsIfacePred p)
 322 hsIfaceType (HsKindSig t _)    = hsIfaceLType t
 323 hsIfaceType (HsNumTy n)        = panic "hsIfaceType:HsNum"
 324 hsIfaceType (HsSpliceTy _)     = panic "hsIfaceType:HsSpliceTy"
 325
 326 -----------
 327 hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys
 328
 329 -----------
 330 hsIfaceCtxt :: [LHsPred RdrName] -> [IfacePredType]
 331 hsIfaceCtxt ctxt = map hsIfaceLPred ctxt
 332
 333 -----------
 334 hsIfaceLPred :: LHsPred RdrName -> IfacePredType
 335 hsIfaceLPred = hsIfacePred . unLoc
 336
 337 hsIfacePred :: HsPred RdrName -> IfacePredType
 338 hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceLTypes ts)
 339 hsIfacePred (HsIParam ip t)   = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceLType t)
 340
 341 -----------
 342 hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType
 343 hs_tc_app (HsAppTy t1 t2) args = hs_tc_app (unLoc t1) (hsIfaceLType t2 : args)
 344 hs_tc_app (HsTyVar n) args
 345   | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args
 346   | otherwise              = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args
 347 hs_tc_app ty args          = foldl IfaceAppTy (hsIfaceType ty) args
 348
 349 -----------
 350 hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
 351
 352 -----------
 353 hsIfaceTv (UserTyVar n)     = (rdrNameOcc n, liftedTypeKind)
 354 hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, k)
 355
 356 -----------
 357 hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
 358 hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys)
 359                  | (xs,ys) <- fds ]
 360 \end{code}
 361
 362 %************************************************************************
 363 %*                                                                      *
 364 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
 365 %*                                                                      *
 366 %************************************************************************
 367
 368 Function definitions are restructured here. Each is assumed to be recursive
 369 initially, and non recursive definitions are discovered by the dependency
 370 analyser.
 371
 372
 373 \begin{code}
 374 -- | Groups together bindings for a single function
 375 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
 376 cvTopDecls decls = go (fromOL decls)
 377   where
 378     go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
 379     go []                   = []
 380     go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'
 381                             where (L l' b', ds') = getMonoBind (L l b) ds
 382     go (d : ds)             = d : go ds
 383
 384 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsBindGroup RdrName
 385 cvBindGroup binding
 386   = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
 387     HsBindGroup mbs sigs Recursive -- just one big group for now
 388     }
 389
 390 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
 391   -> (Bag (LHsBind RdrName), [LSig RdrName])
 392 -- Input decls contain just value bindings and signatures
 393 cvBindsAndSigs  fb = go (fromOL fb)
 394   where
 395     go []                  = (emptyBag, [])
 396     go (L l (SigD s) : ds) = (bs, L l s : ss)
 397                             where (bs,ss) = go ds
 398     go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
 399                             where (b',ds') = getMonoBind (L l b) ds
 400                                   (bs,ss)  = go ds'
 401
 402 -----------------------------------------------------------------------------
 403 -- Group function bindings into equation groups
 404
 405 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
 406   -> (LHsBind RdrName, [LHsDecl RdrName])
 407 -- Suppose      (b',ds') = getMonoBind b ds
 408 --      ds is a *reversed* list of parsed bindings
 409 --      b is a MonoBinds that has just been read off the front
 410
 411 -- Then b' is the result of grouping more equations from ds that
 412 -- belong with b into a single MonoBinds, and ds' is the depleted
 413 -- list of parsed bindings.
 414 --
 415 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 416
 417 getMonoBind (L loc (FunBind lf@(L _ f) inf mtchs)) binds
 418   | has_args mtchs
 419   = go mtchs loc binds
 420   where
 421     go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 mtchs2)) : binds)
 422         | f == unLoc f2 = go (mtchs2++mtchs1) loc binds
 423         where loc = combineSrcSpans loc1 loc2
 424     go mtchs1 loc binds
 425         = (L loc (FunBind lf inf (reverse mtchs1)), binds)
 426         -- reverse the final matches, to get it back in the right order
 427
 428 getMonoBind bind binds = (bind, binds)
 429
 430 has_args ((L _ (Match args _ _)) : _) = not (null args)
 431         -- Don't group together FunBinds if they have
 432         -- no arguments.  This is necessary now that variable bindings
 433         -- with no arguments are now treated as FunBinds rather
 434         -- than pattern bindings (tests/rename/should_fail/rnfail002).
 435 \end{code}
 436
 437 \begin{code}
 438 emptyGroup = HsGroup { hs_valds = [HsBindGroup emptyBag [] Recursive],
 439                        hs_tyclds = [], hs_instds = [],
 440                        hs_fixds = [], hs_defds = [], hs_fords = [],
 441                        hs_depds = [] ,hs_ruleds = [] }
 442
 443 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 444 findSplice ds = addl emptyGroup ds
 445
 446 mkGroup :: [LHsDecl a] -> HsGroup a
 447 mkGroup ds = addImpDecls emptyGroup ds
 448
 449 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
 450 -- The decls are imported, and should not have a splice
 451 addImpDecls group decls = case addl group decls of
 452                                 (group', Nothing) -> group'
 453                                 other             -> panic "addImpDecls"
 454
 455 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 456         -- This stuff reverses the declarations (again) but it doesn't matter
 457
 458 -- Base cases
 459 addl gp []                 = (gp, Nothing)
 460 addl gp (L l d : ds) = add gp l d ds
 461
 462
 463 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
 464   -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 465
 466 add gp l (SpliceD e) ds = (gp, Just (e, ds))
 467
 468 -- Class declarations: pull out the fixity signatures to the top
 469 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
 470         | isClassDecl d =
 471                 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
 472                 addl (gp { hs_tyclds = L l d : ts, hs_fixds  = fsigs ++ fs }) ds
 473         | otherwise =
 474                 addl (gp { hs_tyclds = L l d : ts }) ds
 475
 476 -- Signatures: fixity sigs go a different place than all others
 477 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
 478   = addl (gp {hs_fixds = L l f : ts}) ds
 479 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
 480   = addl (gp {hs_valds = add_sig (L l d) ts}) ds
 481
 482 -- Value declarations: use add_bind
 483 add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
 484   = addl (gp { hs_valds = add_bind (L l d) ts }) ds
 485
 486 -- The rest are routine
 487 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
 488   = addl (gp { hs_instds = L l d : ts }) ds
 489 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
 490   = addl (gp { hs_defds = L l d : ts }) ds
 491 add gp@(HsGroup {hs_fords  = ts})  l (ForD d) ds
 492   = addl (gp { hs_fords = L l d : ts }) ds
 493 add gp@(HsGroup {hs_depds  = ts})  l (DeprecD d) ds
 494   = addl (gp { hs_depds = L l d : ts }) ds
 495 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
 496   = addl (gp { hs_ruleds = L l d : ts }) ds
 497
 498 add_bind b [HsBindGroup bs sigs r] = [HsBindGroup (bs `snocBag` b) sigs     r]
 499 add_sig  s [HsBindGroup bs sigs r] = [HsBindGroup bs               (s:sigs) r]
 500 \end{code}
 501
 502 %************************************************************************
 503 %*                                                                      *
 504 \subsection[PrefixToHS-utils]{Utilities for conversion}
 505 %*                                                                      *
 506 %************************************************************************
 507
 508
 509 \begin{code}
 510 -----------------------------------------------------------------------------
 511 -- mkPrefixCon
 512
 513 -- When parsing data declarations, we sometimes inadvertently parse
 514 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
 515 -- This function splits up the type application, adds any pending
 516 -- arguments, and converts the type constructor back into a data constructor.
 517
 518 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
 519   -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
 520 mkPrefixCon ty tys
 521  = split ty tys
 522  where
 523    split (L _ (HsAppTy t u)) ts = split t (unbangedType u : ts)
 524    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
 525                                      return (data_con, PrefixCon ts)
 526    split (L l _) _              = parseError l "parse error in data/newtype declaration"
 527
 528 mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
 529   -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
 530 mkRecCon (L loc con) fields
 531   = do data_con <- tyConToDataCon loc con
 532        return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
 533
 534 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 535 tyConToDataCon loc tc
 536   | isTcOcc (rdrNameOcc tc)
 537   = return (L loc (setRdrNameSpace tc srcDataName))
 538   | otherwise
 539   = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
 540
 541 ----------------------------------------------------------------------------
 542 -- Various Syntactic Checks
 543
 544 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
 545 checkInstType (L l t)
 546   = case t of
 547         HsForAllTy exp tvs ctxt ty -> do
 548                 dict_ty <- checkDictTy ty
 549                 return (L l (HsForAllTy exp tvs ctxt dict_ty))
 550
 551         HsParTy ty -> checkInstType ty
 552
 553         ty ->   do dict_ty <- checkDictTy (L l ty)
 554                    return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 555
 556 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
 557 checkTyVars tvs
 558   = mapM chk tvs
 559   where
 560         --  Check that the name space is correct!
 561     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
 562         | isRdrTyVar tv = return (L l (KindedTyVar tv k))
 563     chk (L l (HsTyVar tv))
 564         | isRdrTyVar tv = return (L l (UserTyVar tv))
 565     chk (L l other)
 566         = parseError l "Type found where type variable expected"
 567
 568 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
 569   -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
 570 -- The header of a type or class decl should look like
 571 --      (C a, D b) => T a b
 572 -- or   T a b
 573 -- or   a + b
 574 -- etc
 575 checkTyClHdr (L l cxt) ty
 576   = do (tc, tvs) <- gol ty []
 577        mapM_ chk_pred cxt
 578        return (L l cxt, tc, tvs)
 579   where
 580     gol (L l ty) acc = go l ty acc
 581
 582     go l (HsTyVar tc)    acc
 583         | not (isRdrTyVar tc)   = checkTyVars acc               >>= \ tvs ->
 584                                   return (L l tc, tvs)
 585     go l (HsOpTy t1 tc t2) acc  = checkTyVars (t1:t2:acc)       >>= \ tvs ->
 586                                   return (tc, tvs)
 587     go l (HsParTy ty)    acc    = gol ty acc
 588     go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
 589     go l other           acc    = parseError l "Malformed LHS to type of class declaration"
 590
 591         -- The predicates in a type or class decl must all
 592         -- be HsClassPs.  They need not all be type variables,
 593         -- even in Haskell 98.  E.g. class (Monad m, Monad (t m)) => MonadT t m
 594     chk_pred (L l (HsClassP _ args)) = return ()
 595     chk_pred (L l _)
 596        = parseError l "Malformed context in type or class declaration"
 597
 598
 599 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 600 checkContext (L l t)
 601   = check t
 602  where
 603   check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
 604     = do ctx <- mapM checkPred ts
 605          return (L l ctx)
 606
 607   check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
 608     = check (unLoc ty)
 609
 610   check (HsTyVar t)     -- Empty context shows up as a unit type ()
 611     | t == getRdrName unitTyCon = return (L l [])
 612
 613   check t
 614     = do p <- checkPred (L l t)
 615          return (L l [p])
 616
 617
 618 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
 619 -- Watch out.. in ...deriving( Show )... we use checkPred on
 620 -- the list of partially applied predicates in the deriving,
 621 -- so there can be zero args.
 622 checkPred (L spn (HsPredTy (HsIParam n ty)))
 623   = return (L spn (HsIParam n ty))
 624 checkPred (L spn ty)
 625   = check spn ty []
 626   where
 627     checkl (L l ty) args = check l ty args
 628
 629     check loc (HsTyVar t)   args | not (isRdrTyVar t)
 630                              = return (L spn (HsClassP t args))
 631     check loc (HsAppTy l r) args = checkl l (r:args)
 632     check loc (HsParTy t)   args = checkl t args
 633     check loc _             _    = parseError loc  "malformed class assertion"
 634
 635 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
 636 checkDictTy (L spn ty) = check ty []
 637   where
 638   check (HsTyVar t) args | not (isRdrTyVar t)
 639         = return (L spn (HsPredTy (HsClassP t args)))
 640   check (HsAppTy l r) args = check (unLoc l) (r:args)
 641   check (HsParTy t)   args = check (unLoc t) args
 642   check _ _ = parseError spn "Malformed context in instance header"
 643
 644 ---------------------------------------------------------------------------
 645 -- Checking statements in a do-expression
 646 --      We parse   do { e1 ; e2 ; }
 647 --      as [ExprStmt e1, ExprStmt e2]
 648 -- checkDo (a) checks that the last thing is an ExprStmt
 649 --         (b) transforms it to a ResultStmt
 650 -- same comments apply for mdo as well
 651
 652 checkDo  = checkDoMDo "a " "'do'"
 653 checkMDo = checkDoMDo "an " "'mdo'"
 654
 655 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P [LStmt RdrName]
 656 checkDoMDo pre nm loc []   = parseError loc ("Empty " ++ nm ++ " construct")
 657 checkDoMDo pre nm loc ss   = do
 658   check ss
 659   where
 660         check  [L l (ExprStmt e _)] = return [L l (ResultStmt e)]
 661         check  [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
 662                                          " construct must be an expression")
 663         check (s:ss) = do
 664           ss' <-  check ss
 665           return (s:ss')
 666
 667 -- -------------------------------------------------------------------------
 668 -- Checking Patterns.
 669
 670 -- We parse patterns as expressions and check for valid patterns below,
 671 -- converting the expression into a pattern at the same time.
 672
 673 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
 674 checkPattern e = checkLPat e
 675
 676 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
 677 checkPatterns es = mapM checkPattern es
 678
 679 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
 680 checkLPat e@(L l _) = checkPat l e []
 681
 682 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
 683 checkPat loc (L l (HsVar c)) args
 684   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
 685 checkPat loc (L _ (HsApp f x)) args = do
 686   x <- checkLPat x
 687   checkPat loc f (x:args)
 688 checkPat loc (L _ e) [] = do
 689   p <- checkAPat loc e
 690   return (L loc p)
 691 checkPat loc pat _some_args
 692   = patFail loc
 693
 694 checkAPat loc e = case e of
 695    EWildPat            -> return (WildPat placeHolderType)
 696    HsVar x | isQual x  -> parseError loc ("Qualified variable in pattern: "
 697                                          ++ showRdrName x)
 698            | otherwise -> return (VarPat x)
 699    HsLit l             -> return (LitPat l)
 700
 701    -- Overloaded numeric patterns (e.g. f 0 x = x)
 702    -- Negation is recorded separately, so that the literal is zero or +ve
 703    -- NB. Negative *primitive* literals are already handled by
 704    --     RdrHsSyn.mkHsNegApp
 705    HsOverLit pos_lit            -> return (NPatIn pos_lit Nothing)
 706    NegApp (L _ (HsOverLit pos_lit)) _
 707                         -> return (NPatIn pos_lit (Just placeHolderName))
 708
 709    ELazyPat e      -> checkLPat e >>= (return . LazyPat)
 710    EAsPat n e      -> checkLPat e >>= (return . AsPat n)
 711    ExprWithTySig e t  -> checkLPat e >>= \e ->
 712                          -- Pattern signatures are parsed as sigtypes,
 713                          -- but they aren't explicit forall points.  Hence
 714                          -- we have to remove the implicit forall here.
 715                          let t' = case t of
 716                                      L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
 717                                      other -> other
 718                          in
 719                          return (SigPatIn e t')
 720
 721    -- n+k patterns
 722    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
 723         (L _ (HsOverLit lit@(HsIntegral _ _)))
 724                       | plus == plus_RDR
 725                       -> return (mkNPlusKPat (L nloc n) lit)
 726                       where
 727                          plus_RDR = mkUnqual varName FSLIT("+") -- Hack
 728
 729    OpApp l op fix r   -> checkLPat l >>= \l ->
 730                          checkLPat r >>= \r ->
 731                          case op of
 732                             L cl (HsVar c) | isDataOcc (rdrNameOcc c)
 733                                    -> return (ConPatIn (L cl c) (InfixCon l r))
 734                             _ -> patFail loc
 735
 736    HsPar e                 -> checkLPat e >>= (return . ParPat)
 737    ExplicitList _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
 738                          return (ListPat ps placeHolderType)
 739    ExplicitPArr _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
 740                          return (PArrPat ps placeHolderType)
 741
 742    ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
 743                          return (TuplePat ps b)
 744
 745    RecordCon c fs     -> mapM checkPatField fs >>= \fs ->
 746                          return (ConPatIn c (RecCon fs))
 747 -- Generics
 748    HsType ty          -> return (TypePat ty)
 749    _                  -> patFail loc
 750
 751 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
 752 checkPatField (n,e) = do
 753   p <- checkLPat e
 754   return (n,p)
 755
 756 patFail loc = parseError loc "Parse error in pattern"
 757
 758
 759 ---------------------------------------------------------------------------
 760 -- Check Equation Syntax
 761
 762 checkValDef
 763         :: LHsExpr RdrName
 764         -> Maybe (LHsType RdrName)
 765         -> Located (GRHSs RdrName)
 766         -> P (HsBind RdrName)
 767
 768 checkValDef lhs opt_sig (L rhs_span grhss)
 769   | Just (f,inf,es)  <- isFunLhs lhs []
 770   = if isQual (unLoc f)
 771         then parseError (getLoc f) ("Qualified name in function definition: "  ++
 772                                         showRdrName (unLoc f))
 773         else do ps <- checkPatterns es
 774                 return (FunBind f inf [L rhs_span (Match ps opt_sig grhss)])
 775   | otherwise = do
 776         lhs <- checkPattern lhs
 777         return (PatBind lhs grhss)
 778
 779 checkValSig
 780         :: LHsExpr RdrName
 781         -> LHsType RdrName
 782         -> P (Sig RdrName)
 783 checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty)
 784 checkValSig (L l other)     ty
 785   = parseError l "Type signature given for an expression"
 786
 787 -- A variable binding is parsed as a FunBind.
 788
 789 isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
 790   -> Maybe (Located RdrName, Bool, [LHsExpr RdrName])
 791 isFunLhs (L loc e) = isFunLhs' loc e
 792  where
 793    isFunLhs' loc (HsVar f) es
 794         | not (isRdrDataCon f)          = Just (L loc f, False, es)
 795    isFunLhs' loc (HsApp f e) es         = isFunLhs f (e:es)
 796    isFunLhs' loc (HsPar e)   es@(_:_)   = isFunLhs e es
 797    isFunLhs' loc (OpApp l (L loc' (HsVar op)) fix r) es
 798         | not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es))
 799         | otherwise             =
 800                 case isFunLhs l es of
 801                     Just (op', True, j : k : es') ->
 802                       Just (op', True,
 803                             j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es')
 804                     _ -> Nothing
 805    isFunLhs' _ _ _ = Nothing
 806
 807 ---------------------------------------------------------------------------
 808 -- Miscellaneous utilities
 809
 810 checkPrecP :: Located Int -> P Int
 811 checkPrecP (L l i)
 812  | 0 <= i && i <= maxPrecedence = return i
 813  | otherwise                    = parseError l "Precedence out of range"
 814
 815 mkRecConstrOrUpdate
 816         :: LHsExpr RdrName
 817         -> SrcSpan
 818         -> HsRecordBinds RdrName
 819         -> P (HsExpr RdrName)
 820
 821 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
 822   = return (RecordCon (L l c) fs)
 823 mkRecConstrOrUpdate exp loc fs@(_:_)
 824   = return (RecordUpd exp fs)
 825 mkRecConstrOrUpdate _ loc []
 826   = parseError loc "Empty record update"
 827
 828 -----------------------------------------------------------------------------
 829 -- utilities for foreign declarations
 830
 831 -- supported calling conventions
 832 --
 833 data CallConv = CCall  CCallConv        -- ccall or stdcall
 834               | DNCall                  -- .NET
 835
 836 -- construct a foreign import declaration
 837 --
 838 mkImport :: CallConv
 839          -> Safety
 840          -> (Located FastString, Located RdrName, LHsType RdrName)
 841          -> P (HsDecl RdrName)
 842 mkImport (CCall  cconv) safety (entity, v, ty) = do
 843   importSpec <- parseCImport entity cconv safety v
 844   return (ForD (ForeignImport v ty importSpec False))
 845 mkImport (DNCall      ) _      (entity, v, ty) = do
 846   spec <- parseDImport entity
 847   return $ ForD (ForeignImport v ty (DNImport spec) False)
 848
 849 -- parse the entity string of a foreign import declaration for the `ccall' or
 850 -- `stdcall' calling convention'
 851 --
 852 parseCImport :: Located FastString
 853              -> CCallConv
 854              -> Safety
 855              -> Located RdrName
 856              -> P ForeignImport
 857 parseCImport (L loc entity) cconv safety v
 858   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
 859   | entity == FSLIT ("dynamic") =
 860     return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
 861   | entity == FSLIT ("wrapper") =
 862     return $ CImport cconv safety nilFS nilFS CWrapper
 863   | otherwise                  = parse0 (unpackFS entity)
 864     where
 865       -- using the static keyword?
 866       parse0 (' ':                    rest) = parse0 rest
 867       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
 868       parse0                          rest  = parse1 rest
 869       -- check for header file name
 870       parse1     ""               = parse4 ""    nilFS        False nilFS
 871       parse1     (' ':rest)       = parse1 rest
 872       parse1 str@('&':_   )       = parse2 str   nilFS
 873       parse1 str@('[':_   )       = parse3 str   nilFS        False
 874       parse1 str
 875         | ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
 876         | otherwise               = parse4 str   nilFS        False nilFS
 877         where
 878           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
 879       -- check for address operator (indicating a label import)
 880       parse2     ""         header = parse4 ""   header False nilFS
 881       parse2     (' ':rest) header = parse2 rest header
 882       parse2     ('&':rest) header = parse3 rest header True
 883       parse2 str@('[':_   ) header = parse3 str  header False
 884       parse2 str            header = parse4 str  header False nilFS
 885       -- check for library object name
 886       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
 887       parse3 ('[':rest) header isLbl =
 888         case break (== ']') rest of
 889           (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
 890           _                         -> parseError loc "Missing ']' in entity"
 891       parse3 str        header isLbl = parse4 str  header isLbl nilFS
 892       -- check for name of C function
 893       parse4 ""         header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
 894       parse4 (' ':rest) header isLbl lib = parse4 rest                 header isLbl lib
 895       parse4 str        header isLbl lib
 896         | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
 897         | otherwise                      = parseError loc "Malformed entity string"
 898         where
 899           (first, rest) = break (== ' ') str
 900       --
 901       build cid header False lib = return $
 902         CImport cconv safety header lib (CFunction (StaticTarget cid))
 903       build cid header True  lib = return $
 904         CImport cconv safety header lib (CLabel                  cid )
 905
 906 --
 907 -- Unravel a dotnet spec string.
 908 --
 909 parseDImport :: Located FastString -> P DNCallSpec
 910 parseDImport (L loc entity) = parse0 comps
 911  where
 912   comps = words (unpackFS entity)
 913
 914   parse0 [] = d'oh
 915   parse0 (x : xs)
 916     | x == "static" = parse1 True xs
 917     | otherwise     = parse1 False (x:xs)
 918
 919   parse1 _ [] = d'oh
 920   parse1 isStatic (x:xs)
 921     | x == "method" = parse2 isStatic DNMethod xs
 922     | x == "field"  = parse2 isStatic DNField xs
 923     | x == "ctor"   = parse2 isStatic DNConstructor xs
 924   parse1 isStatic xs = parse2 isStatic DNMethod xs
 925
 926   parse2 _ _ [] = d'oh
 927   parse2 isStatic kind (('[':x):xs) =
 928      case x of
 929         [] -> d'oh
 930         vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
 931   parse2 isStatic kind xs = parse3 isStatic kind "" xs
 932
 933   parse3 isStatic kind assem [x] =
 934     return (DNCallSpec isStatic kind assem x
 935                           -- these will be filled in once known.
 936                         (error "FFI-dotnet-args")
 937                         (error "FFI-dotnet-result"))
 938   parse3 _ _ _ _ = d'oh
 939
 940   d'oh = parseError loc "Malformed entity string"
 941
 942 -- construct a foreign export declaration
 943 --
 944 mkExport :: CallConv
 945          -> (Located FastString, Located RdrName, LHsType RdrName)
 946          -> P (HsDecl RdrName)
 947 mkExport (CCall  cconv) (L loc entity, v, ty) = return $
 948   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
 949   where
 950     entity' | nullFastString entity = mkExtName (unLoc v)
 951             | otherwise             = entity
 952 mkExport DNCall (L loc entity, v, ty) =
 953   parseError (getLoc v){-TODO: not quite right-}
 954         "Foreign export is not yet supported for .NET"
 955
 956 -- Supplying the ext_name in a foreign decl is optional; if it
 957 -- isn't there, the Haskell name is assumed. Note that no transformation
 958 -- of the Haskell name is then performed, so if you foreign export (++),
 959 -- it's external name will be "++". Too bad; it's important because we don't
 960 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 961 -- (This is why we use occNameUserString.)
 962 --
 963 mkExtName :: RdrName -> CLabelString
 964 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
 965 \end{code}
 966
 967
 968 -----------------------------------------------------------------------------
 969 -- Misc utils
 970
 971 \begin{code}
 972 showRdrName :: RdrName -> String
 973 showRdrName r = showSDoc (ppr r)
 974
 975 parseError :: SrcSpan -> String -> P a
 976 parseError span s = failSpanMsgP span s
 977 \end{code}