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