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