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