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(..) )
  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 HscTypes         ( GenAvailInfo(..) )
  61 import TysWiredIn       ( unitTyCon )
  62 import ForeignCall      ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
  63                           DNCallSpec(..), DNKind(..))
  64 import OccName          ( OccName, srcDataName, varName, isDataOcc, isTcOcc,
  65                           occNameUserString, isValOcc )
  66 import BasicTypes       ( initialVersion )
  67 import TyCon            ( DataConDetails(..) )
  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 (unLoc 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 { ifND = tcdND decl,
 245                 ifName = rdrNameOcc (tcdName decl),
 246                 ifTyVars = hsIfaceTvs (tcdTyVars decl),
 247                 ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
 248                 ifCons = Unknown, 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 hsIfaceName rdr_name    -- Qualify unqualifed occurrences
 264                                 -- with the module name
 265   | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
 266   | otherwise         = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
 267
 268 hsIfaceLType :: LHsType RdrName -> IfaceType
 269 hsIfaceLType = hsIfaceType . unLoc
 270
 271 hsIfaceType :: HsType RdrName -> IfaceType
 272 hsIfaceType (HsForAllTy exp tvs cxt ty)
 273   = foldr (IfaceForAllTy . hsIfaceTv) rho tvs'
 274   where
 275     rho = foldr (IfaceFunTy . IfacePredTy . hsIfaceLPred) tau (unLoc cxt)
 276     tau = hsIfaceLType ty
 277     tvs' = case exp of
 278              Explicit -> map unLoc tvs
 279              Implicit -> map (UserTyVar . unLoc) (extractHsRhoRdrTyVars cxt ty)
 280
 281 hsIfaceType ty@(HsTyVar _)     = hs_tc_app ty []
 282 hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty []
 283 hsIfaceType (HsFunTy t1 t2)    = IfaceFunTy (hsIfaceLType t1) (hsIfaceLType t2)
 284 hsIfaceType (HsListTy t)       = IfaceTyConApp IfaceListTc [hsIfaceLType t]
 285 hsIfaceType (HsPArrTy t)       = IfaceTyConApp IfacePArrTc [hsIfaceLType t]
 286 hsIfaceType (HsTupleTy bx ts)  = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
 287 hsIfaceType (HsOpTy t1 tc t2)  = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
 288 hsIfaceType (HsParTy t)        = hsIfaceLType t
 289 hsIfaceType (HsPredTy p)       = IfacePredTy (hsIfaceLPred p)
 290 hsIfaceType (HsKindSig t _)    = hsIfaceLType t
 291 hsIfaceType (HsNumTy n)        = panic "hsIfaceType:HsNum"
 292 hsIfaceType (HsSpliceTy _)     = panic "hsIfaceType:HsSpliceTy"
 293
 294 -----------
 295 hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys
 296
 297 -----------
 298 hsIfaceCtxt :: [LHsPred RdrName] -> [IfacePredType]
 299 hsIfaceCtxt ctxt = map hsIfaceLPred ctxt
 300
 301 -----------
 302 hsIfaceLPred :: LHsPred RdrName -> IfacePredType
 303 hsIfaceLPred = hsIfacePred . unLoc
 304
 305 hsIfacePred :: HsPred RdrName -> IfacePredType
 306 hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceLTypes ts)
 307 hsIfacePred (HsIParam ip t)   = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceLType t)
 308
 309 -----------
 310 hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType
 311 hs_tc_app (HsAppTy t1 t2) args = hs_tc_app (unLoc t1) (hsIfaceLType t2 : args)
 312 hs_tc_app (HsTyVar n) args
 313   | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args
 314   | otherwise              = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args
 315 hs_tc_app ty args          = foldl IfaceAppTy (hsIfaceType ty) args
 316
 317 -----------
 318 hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
 319
 320 -----------
 321 hsIfaceTv (UserTyVar n)     = (rdrNameOcc n, IfaceLiftedTypeKind)
 322 hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, toIfaceKind k)
 323
 324 -----------
 325 hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
 326 hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys)
 327                  | (xs,ys) <- fds ]
 328 \end{code}
 329
 330 %************************************************************************
 331 %*                                                                      *
 332 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
 333 %*                                                                      *
 334 %************************************************************************
 335
 336 Function definitions are restructured here. Each is assumed to be recursive
 337 initially, and non recursive definitions are discovered by the dependency
 338 analyser.
 339
 340
 341 \begin{code}
 342 -- | Groups together bindings for a single function
 343 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
 344 cvTopDecls decls = go (fromOL decls)
 345   where
 346     go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
 347     go []                   = []
 348     go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'
 349                             where (L l' b', ds') = getMonoBind (L l b) ds
 350     go (d : ds)             = d : go ds
 351
 352 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsBindGroup RdrName
 353 cvBindGroup binding
 354   = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
 355     HsBindGroup mbs sigs Recursive -- just one big group for now
 356     }
 357
 358 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
 359   -> (Bag (LHsBind RdrName), [LSig RdrName])
 360 -- Input decls contain just value bindings and signatures
 361 cvBindsAndSigs  fb = go (fromOL fb)
 362   where
 363     go []                  = (emptyBag, [])
 364     go (L l (SigD s) : ds) = (bs, L l s : ss)
 365                             where (bs,ss) = go ds
 366     go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
 367                             where (b',ds') = getMonoBind (L l b) ds
 368                                   (bs,ss)  = go ds'
 369
 370 -----------------------------------------------------------------------------
 371 -- Group function bindings into equation groups
 372
 373 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
 374   -> (LHsBind RdrName, [LHsDecl RdrName])
 375 -- Suppose      (b',ds') = getMonoBind b ds
 376 --      ds is a *reversed* list of parsed bindings
 377 --      b is a MonoBinds that has just been read off the front
 378
 379 -- Then b' is the result of grouping more equations from ds that
 380 -- belong with b into a single MonoBinds, and ds' is the depleted
 381 -- list of parsed bindings.
 382 --
 383 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 384
 385 getMonoBind (L loc (FunBind lf@(L _ f) inf mtchs)) binds
 386   | has_args mtchs
 387   = go mtchs loc binds
 388   where
 389     go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 mtchs2)) : binds)
 390         | f == unLoc f2 = go (mtchs2++mtchs1) loc binds
 391         where loc = combineSrcSpans loc1 loc2
 392     go mtchs1 loc binds
 393         = (L loc (FunBind lf inf (reverse mtchs1)), binds)
 394         -- reverse the final matches, to get it back in the right order
 395
 396 getMonoBind bind binds = (bind, binds)
 397
 398 has_args ((L _ (Match args _ _)) : _) = not (null args)
 399         -- Don't group together FunBinds if they have
 400         -- no arguments.  This is necessary now that variable bindings
 401         -- with no arguments are now treated as FunBinds rather
 402         -- than pattern bindings (tests/rename/should_fail/rnfail002).
 403 \end{code}
 404
 405 \begin{code}
 406 emptyGroup = HsGroup { hs_valds = [HsBindGroup emptyBag [] Recursive],
 407                        hs_tyclds = [], hs_instds = [],
 408                        hs_fixds = [], hs_defds = [], hs_fords = [],
 409                        hs_depds = [] ,hs_ruleds = [] }
 410
 411 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 412 findSplice ds = addl emptyGroup ds
 413
 414 mkGroup :: [LHsDecl a] -> HsGroup a
 415 mkGroup ds = addImpDecls emptyGroup ds
 416
 417 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
 418 -- The decls are imported, and should not have a splice
 419 addImpDecls group decls = case addl group decls of
 420                                 (group', Nothing) -> group'
 421                                 other             -> panic "addImpDecls"
 422
 423 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 424         -- This stuff reverses the declarations (again) but it doesn't matter
 425
 426 -- Base cases
 427 addl gp []                 = (gp, Nothing)
 428 addl gp (L l d : ds) = add gp l d ds
 429
 430
 431 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
 432   -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 433
 434 add gp l (SpliceD e) ds = (gp, Just (e, ds))
 435
 436 -- Class declarations: pull out the fixity signatures to the top
 437 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
 438         | isClassDecl d =
 439                 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
 440                 addl (gp { hs_tyclds = L l d : ts, hs_fixds  = fsigs ++ fs }) ds
 441         | otherwise =
 442                 addl (gp { hs_tyclds = L l d : ts }) ds
 443
 444 -- Signatures: fixity sigs go a different place than all others
 445 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
 446   = addl (gp {hs_fixds = L l f : ts}) ds
 447 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
 448   = addl (gp {hs_valds = add_sig (L l d) ts}) ds
 449
 450 -- Value declarations: use add_bind
 451 add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
 452   = addl (gp { hs_valds = add_bind (L l d) ts }) ds
 453
 454 -- The rest are routine
 455 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
 456   = addl (gp { hs_instds = L l d : ts }) ds
 457 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
 458   = addl (gp { hs_defds = L l d : ts }) ds
 459 add gp@(HsGroup {hs_fords  = ts})  l (ForD d) ds
 460   = addl (gp { hs_fords = L l d : ts }) ds
 461 add gp@(HsGroup {hs_depds  = ts})  l (DeprecD d) ds
 462   = addl (gp { hs_depds = L l d : ts }) ds
 463 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
 464   = addl (gp { hs_ruleds = L l d : ts }) ds
 465
 466 add_bind b [HsBindGroup bs sigs r] = [HsBindGroup (bs `snocBag` b) sigs     r]
 467 add_sig  s [HsBindGroup bs sigs r] = [HsBindGroup bs               (s:sigs) r]
 468 \end{code}
 469
 470 %************************************************************************
 471 %*                                                                      *
 472 \subsection[PrefixToHS-utils]{Utilities for conversion}
 473 %*                                                                      *
 474 %************************************************************************
 475
 476
 477 \begin{code}
 478 -----------------------------------------------------------------------------
 479 -- mkPrefixCon
 480
 481 -- When parsing data declarations, we sometimes inadvertently parse
 482 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
 483 -- This function splits up the type application, adds any pending
 484 -- arguments, and converts the type constructor back into a data constructor.
 485
 486 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
 487   -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
 488 mkPrefixCon ty tys
 489  = split ty tys
 490  where
 491    split (L _ (HsAppTy t u)) ts = split t (unbangedType u : ts)
 492    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
 493                                      return (data_con, PrefixCon ts)
 494    split (L l _) _              = parseError l "parse error in data/newtype declaration"
 495
 496 mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
 497   -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
 498 mkRecCon (L loc con) fields
 499   = do data_con <- tyConToDataCon loc con
 500        return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
 501
 502 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 503 tyConToDataCon loc tc
 504   | isTcOcc (rdrNameOcc tc)
 505   = return (L loc (setRdrNameSpace tc srcDataName))
 506   | otherwise
 507   = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
 508
 509 ----------------------------------------------------------------------------
 510 -- Various Syntactic Checks
 511
 512 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
 513 checkInstType (L l t)
 514   = case t of
 515         HsForAllTy exp tvs ctxt ty -> do
 516                 dict_ty <- checkDictTy ty
 517                 return (L l (HsForAllTy exp tvs ctxt dict_ty))
 518
 519         HsParTy ty -> checkInstType ty
 520
 521         ty ->   do dict_ty <- checkDictTy (L l ty)
 522                    return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 523
 524 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
 525 checkTyVars tvs
 526   = mapM chk tvs
 527   where
 528         --  Check that the name space is correct!
 529     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
 530         | isRdrTyVar tv = return (L l (KindedTyVar tv k))
 531     chk (L l (HsTyVar tv))
 532         | isRdrTyVar tv = return (L l (UserTyVar tv))
 533     chk (L l other)
 534         = parseError l "Type found where type variable expected"
 535
 536 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
 537   -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
 538 -- The header of a type or class decl should look like
 539 --      (C a, D b) => T a b
 540 -- or   T a b
 541 -- or   a + b
 542 -- etc
 543 checkTyClHdr (L l cxt) ty
 544   = do (tc, tvs) <- gol ty []
 545        mapM_ chk_pred cxt
 546        return (L l cxt, tc, tvs)
 547   where
 548     gol (L l ty) acc = go l ty acc
 549
 550     go l (HsTyVar tc)    acc
 551         | not (isRdrTyVar tc)   = checkTyVars acc               >>= \ tvs ->
 552                                   return (L l tc, tvs)
 553     go l (HsOpTy t1 tc t2) acc  = checkTyVars (t1:t2:acc)       >>= \ tvs ->
 554                                   return (tc, tvs)
 555     go l (HsParTy ty)    acc    = gol ty acc
 556     go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
 557     go l other           acc    = parseError l "Malformed LHS to type of class declaration"
 558
 559         -- The predicates in a type or class decl must all
 560         -- be HsClassPs.  They need not all be type variables,
 561         -- even in Haskell 98.  E.g. class (Monad m, Monad (t m)) => MonadT t m
 562     chk_pred (L l (HsClassP _ args)) = return ()
 563     chk_pred (L l _)
 564        = parseError l "Malformed context in type or class declaration"
 565
 566
 567 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 568 checkContext (L l t)
 569   = check t
 570  where
 571   check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
 572     = do ctx <- mapM checkPred ts
 573          return (L l ctx)
 574
 575   check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
 576     = check (unLoc ty)
 577
 578   check (HsTyVar t)     -- Empty context shows up as a unit type ()
 579     | t == getRdrName unitTyCon = return (L l [])
 580
 581   check t
 582     = do p <- checkPred (L l t)
 583          return (L l [p])
 584
 585
 586 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
 587 -- Watch out.. in ...deriving( Show )... we use checkPred on
 588 -- the list of partially applied predicates in the deriving,
 589 -- so there can be zero args.
 590 checkPred (L spn (HsPredTy (L _ (HsIParam n ty))) )
 591   = return (L spn (HsIParam n ty))
 592 checkPred (L spn ty)
 593   = check spn ty []
 594   where
 595     checkl (L l ty) args = check l ty args
 596
 597     check loc (HsTyVar t)   args | not (isRdrTyVar t)
 598                              = return (L spn (HsClassP t args))
 599     check loc (HsAppTy l r) args = checkl l (r:args)
 600     check loc (HsParTy t)   args = checkl t args
 601     check loc _             _    = parseError loc  "malformed class assertion"
 602
 603 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
 604 checkDictTy (L spn ty) = check ty []
 605   where
 606   check (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
 607         = return (L spn (HsPredTy (L spn (HsClassP t args))))
 608   check (HsAppTy l r) args = check (unLoc l) (r:args)
 609   check (HsParTy t)   args = check (unLoc t) args
 610   check _ _ = parseError spn "Malformed context in instance header"
 611
 612 ---------------------------------------------------------------------------
 613 -- Checking statements in a do-expression
 614 --      We parse   do { e1 ; e2 ; }
 615 --      as [ExprStmt e1, ExprStmt e2]
 616 -- checkDo (a) checks that the last thing is an ExprStmt
 617 --         (b) transforms it to a ResultStmt
 618 -- same comments apply for mdo as well
 619
 620 checkDo  = checkDoMDo "a " "'do'"
 621 checkMDo = checkDoMDo "an " "'mdo'"
 622
 623 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P [LStmt RdrName]
 624 checkDoMDo pre nm loc []   = parseError loc ("Empty " ++ nm ++ " construct")
 625 checkDoMDo pre nm loc ss   = do
 626   check ss
 627   where
 628         check  [L l (ExprStmt e _)] = return [L l (ResultStmt e)]
 629         check  [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
 630                                          " construct must be an expression")
 631         check (s:ss) = do
 632           ss' <-  check ss
 633           return (s:ss')
 634
 635 -- -------------------------------------------------------------------------
 636 -- Checking Patterns.
 637
 638 -- We parse patterns as expressions and check for valid patterns below,
 639 -- converting the expression into a pattern at the same time.
 640
 641 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
 642 checkPattern e = checkLPat e
 643
 644 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
 645 checkPatterns es = mapM checkPattern es
 646
 647 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
 648 checkLPat e@(L l _) = checkPat l e []
 649
 650 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
 651 checkPat loc (L l (HsVar c)) args
 652   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
 653 checkPat loc (L _ (HsApp f x)) args = do
 654   x <- checkLPat x
 655   checkPat loc f (x:args)
 656 checkPat loc (L _ e) [] = do
 657   p <- checkAPat loc e
 658   return (L loc p)
 659 checkPat loc pat _some_args
 660   = patFail loc
 661
 662 checkAPat loc e = case e of
 663    EWildPat            -> return (WildPat placeHolderType)
 664    HsVar x | isQual x  -> parseError loc ("Qualified variable in pattern: "
 665                                          ++ showRdrName x)
 666            | otherwise -> return (VarPat x)
 667    HsLit l             -> return (LitPat l)
 668
 669    -- Overloaded numeric patterns (e.g. f 0 x = x)
 670    -- Negation is recorded separately, so that the literal is zero or +ve
 671    -- NB. Negative *primitive* literals are already handled by
 672    --     RdrHsSyn.mkHsNegApp
 673    HsOverLit pos_lit            -> return (NPatIn pos_lit Nothing)
 674    NegApp (L _ (HsOverLit pos_lit)) _
 675                         -> return (NPatIn pos_lit (Just placeHolderName))
 676
 677    ELazyPat e      -> checkLPat e >>= (return . LazyPat)
 678    EAsPat n e      -> checkLPat e >>= (return . AsPat n)
 679    ExprWithTySig e t  -> checkLPat e >>= \e ->
 680                          -- Pattern signatures are parsed as sigtypes,
 681                          -- but they aren't explicit forall points.  Hence
 682                          -- we have to remove the implicit forall here.
 683                          let t' = case t of
 684                                      L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
 685                                      other -> other
 686                          in
 687                          return (SigPatIn e t')
 688
 689    -- n+k patterns
 690    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
 691         (L _ (HsOverLit lit@(HsIntegral _ _)))
 692                       | plus == plus_RDR
 693                       -> return (mkNPlusKPat (L nloc n) lit)
 694                       where
 695                          plus_RDR = mkUnqual varName FSLIT("+") -- Hack
 696
 697    OpApp l op fix r   -> checkLPat l >>= \l ->
 698                          checkLPat r >>= \r ->
 699                          case op of
 700                             L cl (HsVar c) | isDataOcc (rdrNameOcc c)
 701                                    -> return (ConPatIn (L cl c) (InfixCon l r))
 702                             _ -> patFail loc
 703
 704    HsPar e                 -> checkLPat e >>= (return . ParPat)
 705    ExplicitList _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
 706                          return (ListPat ps placeHolderType)
 707    ExplicitPArr _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
 708                          return (PArrPat ps placeHolderType)
 709
 710    ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
 711                          return (TuplePat ps b)
 712
 713    RecordCon c fs     -> mapM checkPatField fs >>= \fs ->
 714                          return (ConPatIn c (RecCon fs))
 715 -- Generics
 716    HsType ty          -> return (TypePat ty)
 717    _                  -> patFail loc
 718
 719 checkAPat loc _ = patFail loc
 720
 721 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
 722 checkPatField (n,e) = do
 723   p <- checkLPat e
 724   return (n,p)
 725
 726 patFail loc = parseError loc "Parse error in pattern"
 727
 728
 729 ---------------------------------------------------------------------------
 730 -- Check Equation Syntax
 731
 732 checkValDef
 733         :: LHsExpr RdrName
 734         -> Maybe (LHsType RdrName)
 735         -> GRHSs RdrName
 736         -> P (HsBind RdrName)
 737
 738 checkValDef lhs opt_sig grhss
 739   | Just (f,inf,es)  <- isFunLhs lhs []
 740   = if isQual (unLoc f)
 741         then parseError (getLoc f) ("Qualified name in function definition: "  ++
 742                                         showRdrName (unLoc f))
 743         else do ps <- checkPatterns es
 744                 return (FunBind f inf [L (getLoc f) (Match ps opt_sig grhss)])
 745                         -- TODO: span is wrong
 746   | otherwise = do
 747         lhs <- checkPattern lhs
 748         return (PatBind lhs grhss)
 749
 750 checkValSig
 751         :: LHsExpr RdrName
 752         -> LHsType RdrName
 753         -> P (Sig RdrName)
 754 checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty)
 755 checkValSig (L l other)     ty
 756   = parseError l "Type signature given for an expression"
 757
 758 -- A variable binding is parsed as a FunBind.
 759
 760 isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
 761   -> Maybe (Located RdrName, Bool, [LHsExpr RdrName])
 762 isFunLhs (L loc e) = isFunLhs' loc e
 763  where
 764    isFunLhs' loc (HsVar f) es
 765         | not (isRdrDataCon f)          = Just (L loc f, False, es)
 766    isFunLhs' loc (HsApp f e) es         = isFunLhs f (e:es)
 767    isFunLhs' loc (HsPar e)   es@(_:_)   = isFunLhs e es
 768    isFunLhs' loc (OpApp l (L loc' (HsVar op)) fix r) es
 769         | not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es))
 770         | otherwise             =
 771                 case isFunLhs l es of
 772                     Just (op', True, j : k : es') ->
 773                       Just (op', True,
 774                             j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es')
 775                     _ -> Nothing
 776    isFunLhs' _ _ _ = Nothing
 777
 778 ---------------------------------------------------------------------------
 779 -- Miscellaneous utilities
 780
 781 checkPrecP :: Located Int -> P Int
 782 checkPrecP (L l i)
 783  | 0 <= i && i <= maxPrecedence = return i
 784  | otherwise                    = parseError l "Precedence out of range"
 785
 786 mkRecConstrOrUpdate
 787         :: LHsExpr RdrName
 788         -> SrcSpan
 789         -> HsRecordBinds RdrName
 790         -> P (HsExpr RdrName)
 791
 792 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
 793   = return (RecordCon (L l c) fs)
 794 mkRecConstrOrUpdate exp loc fs@(_:_)
 795   = return (RecordUpd exp fs)
 796 mkRecConstrOrUpdate _ loc []
 797   = parseError loc "Empty record update"
 798
 799 -----------------------------------------------------------------------------
 800 -- utilities for foreign declarations
 801
 802 -- supported calling conventions
 803 --
 804 data CallConv = CCall  CCallConv        -- ccall or stdcall
 805               | DNCall                  -- .NET
 806
 807 -- construct a foreign import declaration
 808 --
 809 mkImport :: CallConv
 810          -> Safety
 811          -> (Located FastString, Located RdrName, LHsType RdrName)
 812          -> P (HsDecl RdrName)
 813 mkImport (CCall  cconv) safety (entity, v, ty) = do
 814   importSpec <- parseCImport entity cconv safety v
 815   return (ForD (ForeignImport v ty importSpec False))
 816 mkImport (DNCall      ) _      (entity, v, ty) = do
 817   spec <- parseDImport entity
 818   return $ ForD (ForeignImport v ty (DNImport spec) False)
 819
 820 -- parse the entity string of a foreign import declaration for the `ccall' or
 821 -- `stdcall' calling convention'
 822 --
 823 parseCImport :: Located FastString
 824              -> CCallConv
 825              -> Safety
 826              -> Located RdrName
 827              -> P ForeignImport
 828 parseCImport (L loc entity) cconv safety v
 829   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
 830   | entity == FSLIT ("dynamic") =
 831     return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
 832   | entity == FSLIT ("wrapper") =
 833     return $ CImport cconv safety nilFS nilFS CWrapper
 834   | otherwise                  = parse0 (unpackFS entity)
 835     where
 836       -- using the static keyword?
 837       parse0 (' ':                    rest) = parse0 rest
 838       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
 839       parse0                          rest  = parse1 rest
 840       -- check for header file name
 841       parse1     ""               = parse4 ""    nilFS        False nilFS
 842       parse1     (' ':rest)       = parse1 rest
 843       parse1 str@('&':_   )       = parse2 str   nilFS
 844       parse1 str@('[':_   )       = parse3 str   nilFS        False
 845       parse1 str
 846         | ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
 847         | otherwise               = parse4 str   nilFS        False nilFS
 848         where
 849           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
 850       -- check for address operator (indicating a label import)
 851       parse2     ""         header = parse4 ""   header False nilFS
 852       parse2     (' ':rest) header = parse2 rest header
 853       parse2     ('&':rest) header = parse3 rest header True
 854       parse2 str@('[':_   ) header = parse3 str  header False
 855       parse2 str            header = parse4 str  header False nilFS
 856       -- check for library object name
 857       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
 858       parse3 ('[':rest) header isLbl =
 859         case break (== ']') rest of
 860           (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
 861           _                         -> parseError loc "Missing ']' in entity"
 862       parse3 str        header isLbl = parse4 str  header isLbl nilFS
 863       -- check for name of C function
 864       parse4 ""         header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
 865       parse4 (' ':rest) header isLbl lib = parse4 rest                 header isLbl lib
 866       parse4 str        header isLbl lib
 867         | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
 868         | otherwise                      = parseError loc "Malformed entity string"
 869         where
 870           (first, rest) = break (== ' ') str
 871       --
 872       build cid header False lib = return $
 873         CImport cconv safety header lib (CFunction (StaticTarget cid))
 874       build cid header True  lib = return $
 875         CImport cconv safety header lib (CLabel                  cid )
 876
 877 --
 878 -- Unravel a dotnet spec string.
 879 --
 880 parseDImport :: Located FastString -> P DNCallSpec
 881 parseDImport (L loc entity) = parse0 comps
 882  where
 883   comps = words (unpackFS entity)
 884
 885   parse0 [] = d'oh
 886   parse0 (x : xs)
 887     | x == "static" = parse1 True xs
 888     | otherwise     = parse1 False (x:xs)
 889
 890   parse1 _ [] = d'oh
 891   parse1 isStatic (x:xs)
 892     | x == "method" = parse2 isStatic DNMethod xs
 893     | x == "field"  = parse2 isStatic DNField xs
 894     | x == "ctor"   = parse2 isStatic DNConstructor xs
 895   parse1 isStatic xs = parse2 isStatic DNMethod xs
 896
 897   parse2 _ _ [] = d'oh
 898   parse2 isStatic kind (('[':x):xs) =
 899      case x of
 900         [] -> d'oh
 901         vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
 902   parse2 isStatic kind xs = parse3 isStatic kind "" xs
 903
 904   parse3 isStatic kind assem [x] =
 905     return (DNCallSpec isStatic kind assem x
 906                           -- these will be filled in once known.
 907                         (error "FFI-dotnet-args")
 908                         (error "FFI-dotnet-result"))
 909   parse3 _ _ _ _ = d'oh
 910
 911   d'oh = parseError loc "Malformed entity string"
 912
 913 -- construct a foreign export declaration
 914 --
 915 mkExport :: CallConv
 916          -> (Located FastString, Located RdrName, LHsType RdrName)
 917          -> P (HsDecl RdrName)
 918 mkExport (CCall  cconv) (L loc entity, v, ty) = return $
 919   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
 920   where
 921     entity' | nullFastString entity = mkExtName (unLoc v)
 922             | otherwise             = entity
 923 mkExport DNCall (L loc entity, v, ty) =
 924   parseError (getLoc v){-TODO: not quite right-}
 925         "Foreign export is not yet supported for .NET"
 926
 927 -- Supplying the ext_name in a foreign decl is optional; if it
 928 -- isn't there, the Haskell name is assumed. Note that no transformation
 929 -- of the Haskell name is then performed, so if you foreign export (++),
 930 -- it's external name will be "++". Too bad; it's important because we don't
 931 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 932 -- (This is why we use occNameUserString.)
 933 --
 934 mkExtName :: RdrName -> CLabelString
 935 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
 936 \end{code}
 937
 938
 939 -----------------------------------------------------------------------------
 940 -- Misc utils
 941
 942 \begin{code}
 943 showRdrName :: RdrName -> String
 944 showRdrName r = showSDoc (ppr r)
 945
 946 parseError :: SrcSpan -> String -> P a
 947 parseError span s = failSpanMsgP span s
 948 \end{code}