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