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