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
  17         cvBindGroup,
  18         cvBindsAndSigs,
  19         cvTopDecls,
  20         findSplice, mkGroup,
  21
  22         -- Stuff to do with Foreign declarations
  23         CallConv(..),
  24         mkImport,            -- CallConv -> Safety
  25                               -- -> (FastString, RdrName, RdrNameHsType)
  26                               -- -> P RdrNameHsDecl
  27         mkExport,            -- CallConv
  28                               -- -> (FastString, RdrName, RdrNameHsType)
  29                               -- -> P RdrNameHsDecl
  30         mkExtName,           -- RdrName -> CLabelString
  31
  32         -- Bunch of functions in the parser monad for
  33         -- checking and constructing values
  34         checkPrecP,           -- Int -> P Int
  35         checkContext,         -- HsType -> P HsContext
  36         checkPred,            -- HsType -> P HsPred
  37         checkTyClHdr,
  38         checkSynHdr,
  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 RdrName          ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
  53                           isRdrDataCon, isUnqual, getRdrName, isQual,
  54                           setRdrNameSpace )
  55 import BasicTypes       ( maxPrecedence )
  56 import Lexer            ( P, failSpanMsgP )
  57 import TysWiredIn       ( unitTyCon )
  58 import ForeignCall      ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
  59                           DNCallSpec(..), DNKind(..), CLabelString )
  60 import OccName          ( srcDataName, varName, isDataOcc, isTcOcc,
  61                           occNameUserString )
  62 import SrcLoc
  63 import OrdList          ( OrdList, fromOL )
  64 import Bag              ( Bag, emptyBag, snocBag, consBag, foldrBag )
  65 import Outputable
  66 import FastString
  67 import Panic
  68
  69 import List             ( isSuffixOf, nubBy )
  70 \end{code}
  71
  72
  73 %************************************************************************
  74 %*                                                                      *
  75 \subsection{A few functions over HsSyn at RdrName}
  76 %*                                                                    *
  77 %************************************************************************
  78
  79 extractHsTyRdrNames finds the free variables of a HsType
  80 It's used when making the for-alls explicit.
  81
  82 \begin{code}
  83 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
  84 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
  85
  86 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
  87 -- This one takes the context and tau-part of a
  88 -- sigma type and returns their free type variables
  89 extractHsRhoRdrTyVars ctxt ty
  90  = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
  91
  92 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
  93
  94 extract_pred (HsClassP cls tys) acc     = foldr extract_lty acc tys
  95 extract_pred (HsIParam n ty) acc        = extract_lty ty acc
  96
  97 extract_lty (L loc ty) acc
  98   = case ty of
  99       HsTyVar tv                -> extract_tv loc tv acc
 100       HsBangTy _ ty             -> extract_lty ty acc
 101       HsAppTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
 102       HsListTy ty               -> extract_lty ty acc
 103       HsPArrTy ty               -> extract_lty ty acc
 104       HsTupleTy _ tys           -> foldr extract_lty acc tys
 105       HsFunTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
 106       HsPredTy p                -> extract_pred p acc
 107       HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
 108       HsParTy ty                -> extract_lty ty acc
 109       HsNumTy num               -> acc
 110       HsSpliceTy _              -> acc  -- Type splices mention no type variables
 111       HsKindSig ty k            -> extract_lty ty acc
 112       HsForAllTy exp [] cx ty   -> extract_lctxt cx (extract_lty ty acc)
 113       HsForAllTy exp tvs cx ty  -> acc ++ (filter ((`notElem` locals) . unLoc) $
 114                                            extract_lctxt cx (extract_lty ty []))
 115                                 where
 116                                    locals = hsLTyVarNames tvs
 117
 118 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
 119 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
 120                       | otherwise     = acc
 121
 122 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
 123 -- Get the type variables out of the type patterns in a bunch of
 124 -- possibly-generic bindings in a class declaration
 125 extractGenericPatTyVars binds
 126   = nubBy eqLocated (foldrBag get [] binds)
 127   where
 128     get (L _ (FunBind _ _ (MatchGroup ms _) _)) acc = foldr (get_m.unLoc) acc ms
 129     get other                                   acc = acc
 130
 131     get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
 132     get_m other                                    acc = acc
 133 \end{code}
 134
 135
 136 %************************************************************************
 137 %*                                                                      *
 138 \subsection{Construction functions for Rdr stuff}
 139 %*                                                                    *
 140 %************************************************************************
 141
 142 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
 143 by deriving them from the name of the class.  We fill in the names for the
 144 tycon and datacon corresponding to the class, by deriving them from the
 145 name of the class itself.  This saves recording the names in the interface
 146 file (which would be equally good).
 147
 148 Similarly for mkConDecl, mkClassOpSig and default-method names.
 149
 150         *** See "THE NAMING STORY" in HsDecls ****
 151
 152 \begin{code}
 153 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
 154   = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
 155                 tcdFDs = fds,
 156                 tcdSigs = sigs,
 157                 tcdMeths = mbinds
 158                 }
 159
 160 mkTyData new_or_data (L _ (context, tname, tyvars)) ksig data_cons maybe_deriv
 161   = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
 162              tcdTyVars = tyvars,  tcdCons = data_cons,
 163              tcdKindSig = ksig, tcdDerivs = maybe_deriv }
 164 \end{code}
 165
 166 \begin{code}
 167 mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
 168 -- RdrName If the type checker sees (negate 3#) it will barf, because negate
 169 -- can't take an unboxed arg.  But that is exactly what it will see when
 170 -- we write "-3#".  So we have to do the negation right now!
 171 mkHsNegApp (L loc e) = f e
 172   where f (HsLit (HsIntPrim i))    = HsLit (HsIntPrim (-i))
 173         f (HsLit (HsFloatPrim i))  = HsLit (HsFloatPrim (-i))
 174         f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
 175         f expr                     = NegApp (L loc e) noSyntaxExpr
 176 \end{code}
 177
 178 %************************************************************************
 179 %*                                                                      *
 180 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
 181 %*                                                                      *
 182 %************************************************************************
 183
 184 Function definitions are restructured here. Each is assumed to be recursive
 185 initially, and non recursive definitions are discovered by the dependency
 186 analyser.
 187
 188
 189 \begin{code}
 190 --  | Groups together bindings for a single function
 191 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
 192 cvTopDecls decls = go (fromOL decls)
 193   where
 194     go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
 195     go []                   = []
 196     go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'
 197                             where (L l' b', ds') = getMonoBind (L l b) ds
 198     go (d : ds)             = d : go ds
 199
 200 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
 201 cvBindGroup binding
 202   = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
 203     ValBindsIn mbs sigs
 204     }
 205
 206 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
 207   -> (Bag (LHsBind RdrName), [LSig RdrName])
 208 -- Input decls contain just value bindings and signatures
 209 cvBindsAndSigs  fb = go (fromOL fb)
 210   where
 211     go []                  = (emptyBag, [])
 212     go (L l (SigD s) : ds) = (bs, L l s : ss)
 213                             where (bs,ss) = go ds
 214     go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
 215                             where (b',ds') = getMonoBind (L l b) ds
 216                                   (bs,ss)  = go ds'
 217
 218 -----------------------------------------------------------------------------
 219 -- Group function bindings into equation groups
 220
 221 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
 222   -> (LHsBind RdrName, [LHsDecl RdrName])
 223 -- Suppose      (b',ds') = getMonoBind b ds
 224 --      ds is a *reversed* list of parsed bindings
 225 --      b is a MonoBinds that has just been read off the front
 226
 227 -- Then b' is the result of grouping more equations from ds that
 228 -- belong with b into a single MonoBinds, and ds' is the depleted
 229 -- list of parsed bindings.
 230 --
 231 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 232
 233 getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _) _)) binds
 234   | has_args mtchs
 235   = go mtchs loc binds
 236   where
 237     go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 (MatchGroup mtchs2 _) _)) : binds)
 238         | f == unLoc f2 = go (mtchs2++mtchs1) loc binds
 239         where loc = combineSrcSpans loc1 loc2
 240     go mtchs1 loc binds
 241         = (L loc (FunBind lf inf (mkMatchGroup (reverse mtchs1)) placeHolderNames), binds)
 242         -- Reverse the final matches, to get it back in the right order
 243
 244 getMonoBind bind binds = (bind, binds)
 245
 246 has_args ((L _ (Match args _ _)) : _) = not (null args)
 247         -- Don't group together FunBinds if they have
 248         -- no arguments.  This is necessary now that variable bindings
 249         -- with no arguments are now treated as FunBinds rather
 250         -- than pattern bindings (tests/rename/should_fail/rnfail002).
 251 \end{code}
 252
 253 \begin{code}
 254 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 255 findSplice ds = addl emptyRdrGroup ds
 256
 257 mkGroup :: [LHsDecl a] -> HsGroup a
 258 mkGroup ds = addImpDecls emptyRdrGroup ds
 259
 260 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
 261 -- The decls are imported, and should not have a splice
 262 addImpDecls group decls = case addl group decls of
 263                                 (group', Nothing) -> group'
 264                                 other             -> panic "addImpDecls"
 265
 266 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 267         -- This stuff reverses the declarations (again) but it doesn't matter
 268
 269 -- Base cases
 270 addl gp []           = (gp, Nothing)
 271 addl gp (L l d : ds) = add gp l d ds
 272
 273
 274 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
 275   -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 276
 277 add gp l (SpliceD e) ds = (gp, Just (e, ds))
 278
 279 -- Class declarations: pull out the fixity signatures to the top
 280 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
 281         | isClassDecl d =
 282                 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
 283                 addl (gp { hs_tyclds = L l d : ts, hs_fixds  = fsigs ++ fs }) ds
 284         | otherwise =
 285                 addl (gp { hs_tyclds = L l d : ts }) ds
 286
 287 -- Signatures: fixity sigs go a different place than all others
 288 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
 289   = addl (gp {hs_fixds = L l f : ts}) ds
 290 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
 291   = addl (gp {hs_valds = add_sig (L l d) ts}) ds
 292
 293 -- Value declarations: use add_bind
 294 add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
 295   = addl (gp { hs_valds = add_bind (L l d) ts }) ds
 296
 297 -- The rest are routine
 298 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
 299   = addl (gp { hs_instds = L l d : ts }) ds
 300 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
 301   = addl (gp { hs_defds = L l d : ts }) ds
 302 add gp@(HsGroup {hs_fords  = ts})  l (ForD d) ds
 303   = addl (gp { hs_fords = L l d : ts }) ds
 304 add gp@(HsGroup {hs_depds  = ts})  l (DeprecD d) ds
 305   = addl (gp { hs_depds = L l d : ts }) ds
 306 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
 307   = addl (gp { hs_ruleds = L l d : ts }) ds
 308
 309 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
 310 add_sig  s (ValBindsIn bs sigs) = ValBindsIn bs               (s:sigs)
 311 \end{code}
 312
 313 %************************************************************************
 314 %*                                                                      *
 315 \subsection[PrefixToHS-utils]{Utilities for conversion}
 316 %*                                                                      *
 317 %************************************************************************
 318
 319
 320 \begin{code}
 321 -----------------------------------------------------------------------------
 322 -- mkPrefixCon
 323
 324 -- When parsing data declarations, we sometimes inadvertently parse
 325 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
 326 -- This function splits up the type application, adds any pending
 327 -- arguments, and converts the type constructor back into a data constructor.
 328
 329 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
 330   -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
 331 mkPrefixCon ty tys
 332  = split ty tys
 333  where
 334    split (L _ (HsAppTy t u)) ts = split t (u : ts)
 335    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
 336                                      return (data_con, PrefixCon ts)
 337    split (L l _) _              = parseError l "parse error in data/newtype declaration"
 338
 339 mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
 340   -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
 341 mkRecCon (L loc con) fields
 342   = do data_con <- tyConToDataCon loc con
 343        return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
 344
 345 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 346 tyConToDataCon loc tc
 347   | isTcOcc (rdrNameOcc tc)
 348   = return (L loc (setRdrNameSpace tc srcDataName))
 349   | otherwise
 350   = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
 351
 352 ----------------------------------------------------------------------------
 353 -- Various Syntactic Checks
 354
 355 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
 356 checkInstType (L l t)
 357   = case t of
 358         HsForAllTy exp tvs ctxt ty -> do
 359                 dict_ty <- checkDictTy ty
 360                 return (L l (HsForAllTy exp tvs ctxt dict_ty))
 361
 362         HsParTy ty -> checkInstType ty
 363
 364         ty ->   do dict_ty <- checkDictTy (L l ty)
 365                    return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 366
 367 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
 368 checkTyVars tvs
 369   = mapM chk tvs
 370   where
 371         --  Check that the name space is correct!
 372     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
 373         | isRdrTyVar tv = return (L l (KindedTyVar tv k))
 374     chk (L l (HsTyVar tv))
 375         | isRdrTyVar tv = return (L l (UserTyVar tv))
 376     chk (L l other)
 377         = parseError l "Type found where type variable expected"
 378
 379 checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
 380 checkSynHdr ty = do { (_, tc, tvs) <- checkTyClHdr (noLoc []) ty
 381                     ; return (tc, tvs) }
 382
 383 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
 384   -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
 385 -- The header of a type or class decl should look like
 386 --      (C a, D b) => T a b
 387 -- or   T a b
 388 -- or   a + b
 389 -- etc
 390 checkTyClHdr (L l cxt) ty
 391   = do (tc, tvs) <- gol ty []
 392        mapM_ chk_pred cxt
 393        return (L l cxt, tc, tvs)
 394   where
 395     gol (L l ty) acc = go l ty acc
 396
 397     go l (HsTyVar tc)    acc
 398         | not (isRdrTyVar tc)   = checkTyVars acc               >>= \ tvs ->
 399                                   return (L l tc, tvs)
 400     go l (HsOpTy t1 tc t2) acc  = checkTyVars (t1:t2:acc)       >>= \ tvs ->
 401                                   return (tc, tvs)
 402     go l (HsParTy ty)    acc    = gol ty acc
 403     go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
 404     go l other           acc    = parseError l "Malformed LHS to type of class declaration"
 405
 406         -- The predicates in a type or class decl must all
 407         -- be HsClassPs.  They need not all be type variables,
 408         -- even in Haskell 98.  E.g. class (Monad m, Monad (t m)) => MonadT t m
 409     chk_pred (L l (HsClassP _ args)) = return ()
 410     chk_pred (L l _)
 411        = parseError l "Malformed context in type or class declaration"
 412
 413
 414 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 415 checkContext (L l t)
 416   = check t
 417  where
 418   check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
 419     = do ctx <- mapM checkPred ts
 420          return (L l ctx)
 421
 422   check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
 423     = check (unLoc ty)
 424
 425   check (HsTyVar t)     -- Empty context shows up as a unit type ()
 426     | t == getRdrName unitTyCon = return (L l [])
 427
 428   check t
 429     = do p <- checkPred (L l t)
 430          return (L l [p])
 431
 432
 433 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
 434 -- Watch out.. in ...deriving( Show )... we use checkPred on
 435 -- the list of partially applied predicates in the deriving,
 436 -- so there can be zero args.
 437 checkPred (L spn (HsPredTy (HsIParam n ty)))
 438   = return (L spn (HsIParam n ty))
 439 checkPred (L spn ty)
 440   = check spn ty []
 441   where
 442     checkl (L l ty) args = check l ty args
 443
 444     check _loc (HsTyVar t)             args | not (isRdrTyVar t)
 445                                             = return (L spn (HsClassP t args))
 446     check _loc (HsAppTy l r)           args = checkl l (r:args)
 447     check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
 448     check _loc (HsParTy t)             args = checkl t args
 449     check loc _                        _    = parseError loc  "malformed class assertion"
 450
 451 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
 452 checkDictTy (L spn ty) = check ty []
 453   where
 454   check (HsTyVar t) args | not (isRdrTyVar t)
 455         = return (L spn (HsPredTy (HsClassP t args)))
 456   check (HsAppTy l r) args = check (unLoc l) (r:args)
 457   check (HsParTy t)   args = check (unLoc t) args
 458   check _ _ = parseError spn "Malformed context in instance header"
 459
 460 ---------------------------------------------------------------------------
 461 -- Checking statements in a do-expression
 462 --      We parse   do { e1 ; e2 ; }
 463 --      as [ExprStmt e1, ExprStmt e2]
 464 -- checkDo (a) checks that the last thing is an ExprStmt
 465 --         (b) returns it separately
 466 -- same comments apply for mdo as well
 467
 468 checkDo  = checkDoMDo "a " "'do'"
 469 checkMDo = checkDoMDo "an " "'mdo'"
 470
 471 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
 472 checkDoMDo pre nm loc []   = parseError loc ("Empty " ++ nm ++ " construct")
 473 checkDoMDo pre nm loc ss   = do
 474   check ss
 475   where
 476         check  [L l (ExprStmt e _ _)] = return ([], e)
 477         check  [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
 478                                          " construct must be an expression")
 479         check (s:ss) = do
 480           (ss',e') <-  check ss
 481           return ((s:ss'),e')
 482
 483 -- -------------------------------------------------------------------------
 484 -- Checking Patterns.
 485
 486 -- We parse patterns as expressions and check for valid patterns below,
 487 -- converting the expression into a pattern at the same time.
 488
 489 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
 490 checkPattern e = checkLPat e
 491
 492 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
 493 checkPatterns es = mapM checkPattern es
 494
 495 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
 496 checkLPat e@(L l _) = checkPat l e []
 497
 498 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
 499 checkPat loc (L l (HsVar c)) args
 500   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
 501 checkPat loc (L _ (HsApp f x)) args = do
 502   x <- checkLPat x
 503   checkPat loc f (x:args)
 504 checkPat loc (L _ e) [] = do
 505   p <- checkAPat loc e
 506   return (L loc p)
 507 checkPat loc pat _some_args
 508   = patFail loc
 509
 510 checkAPat loc e = case e of
 511    EWildPat            -> return (WildPat placeHolderType)
 512    HsVar x | isQual x  -> parseError loc ("Qualified variable in pattern: "
 513                                          ++ showRdrName x)
 514            | otherwise -> return (VarPat x)
 515    HsLit l             -> return (LitPat l)
 516
 517    -- Overloaded numeric patterns (e.g. f 0 x = x)
 518    -- Negation is recorded separately, so that the literal is zero or +ve
 519    -- NB. Negative *primitive* literals are already handled by
 520    --     RdrHsSyn.mkHsNegApp
 521    HsOverLit pos_lit            -> return (mkNPat pos_lit Nothing)
 522    NegApp (L _ (HsOverLit pos_lit)) _
 523                         -> return (mkNPat pos_lit (Just noSyntaxExpr))
 524
 525    ELazyPat e      -> checkLPat e >>= (return . LazyPat)
 526    EAsPat n e      -> checkLPat e >>= (return . AsPat n)
 527    ExprWithTySig e t  -> checkLPat e >>= \e ->
 528                          -- Pattern signatures are parsed as sigtypes,
 529                          -- but they aren't explicit forall points.  Hence
 530                          -- we have to remove the implicit forall here.
 531                          let t' = case t of
 532                                      L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
 533                                      other -> other
 534                          in
 535                          return (SigPatIn e t')
 536
 537    -- n+k patterns
 538    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
 539         (L _ (HsOverLit lit@(HsIntegral _ _)))
 540                       | plus == plus_RDR
 541                       -> return (mkNPlusKPat (L nloc n) lit)
 542                       where
 543                          plus_RDR = mkUnqual varName FSLIT("+") -- Hack
 544
 545    OpApp l op fix r   -> checkLPat l >>= \l ->
 546                          checkLPat r >>= \r ->
 547                          case op of
 548                             L cl (HsVar c) | isDataOcc (rdrNameOcc c)
 549                                    -> return (ConPatIn (L cl c) (InfixCon l r))
 550                             _ -> patFail loc
 551
 552    HsPar e                 -> checkLPat e >>= (return . ParPat)
 553    ExplicitList _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
 554                          return (ListPat ps placeHolderType)
 555    ExplicitPArr _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
 556                          return (PArrPat ps placeHolderType)
 557
 558    ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
 559                          return (TuplePat ps b)
 560
 561    RecordCon c _ fs   -> mapM checkPatField fs >>= \fs ->
 562                          return (ConPatIn c (RecCon fs))
 563 -- Generics
 564    HsType ty          -> return (TypePat ty)
 565    _                  -> patFail loc
 566
 567 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
 568 checkPatField (n,e) = do
 569   p <- checkLPat e
 570   return (n,p)
 571
 572 patFail loc = parseError loc "Parse error in pattern"
 573
 574
 575 ---------------------------------------------------------------------------
 576 -- Check Equation Syntax
 577
 578 checkValDef
 579         :: LHsExpr RdrName
 580         -> Maybe (LHsType RdrName)
 581         -> Located (GRHSs RdrName)
 582         -> P (HsBind RdrName)
 583
 584 checkValDef lhs opt_sig (L rhs_span grhss)
 585   | Just (f,inf,es)  <- isFunLhs lhs []
 586   = if isQual (unLoc f)
 587         then parseError (getLoc f) ("Qualified name in function definition: "  ++
 588                                         showRdrName (unLoc f))
 589         else do ps <- checkPatterns es
 590                 let match_span = combineSrcSpans (getLoc lhs) rhs_span
 591                     matches    = mkMatchGroup [L match_span (Match ps opt_sig grhss)]
 592                 return (FunBind f inf matches  placeHolderNames)
 593         -- The span of the match covers the entire equation.
 594         -- That isn't quite right, but it'll do for now.
 595   | otherwise = do
 596         lhs <- checkPattern lhs
 597         return (PatBind lhs grhss placeHolderType placeHolderNames)
 598
 599 checkValSig
 600         :: LHsExpr RdrName
 601         -> LHsType RdrName
 602         -> P (Sig RdrName)
 603 checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty)
 604 checkValSig (L l other)     ty
 605   = parseError l "Type signature given for an expression"
 606
 607 -- A variable binding is parsed as a FunBind.
 608
 609 isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
 610   -> Maybe (Located RdrName, Bool, [LHsExpr RdrName])
 611 isFunLhs (L loc e) = isFunLhs' loc e
 612  where
 613    isFunLhs' loc (HsVar f) es
 614         | not (isRdrDataCon f)          = Just (L loc f, False, es)
 615    isFunLhs' loc (HsApp f e) es         = isFunLhs f (e:es)
 616    isFunLhs' loc (HsPar e)   es@(_:_)   = isFunLhs e es
 617    isFunLhs' loc (OpApp l (L loc' (HsVar op)) fix r) es
 618         | not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es))
 619         | otherwise             =
 620                 case isFunLhs l es of
 621                     Just (op', True, j : k : es') ->
 622                       Just (op', True,
 623                             j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es')
 624                     _ -> Nothing
 625    isFunLhs' _ _ _ = Nothing
 626
 627 ---------------------------------------------------------------------------
 628 -- Miscellaneous utilities
 629
 630 checkPrecP :: Located Int -> P Int
 631 checkPrecP (L l i)
 632  | 0 <= i && i <= maxPrecedence = return i
 633  | otherwise                    = parseError l "Precedence out of range"
 634
 635 mkRecConstrOrUpdate
 636         :: LHsExpr RdrName
 637         -> SrcSpan
 638         -> HsRecordBinds RdrName
 639         -> P (HsExpr RdrName)
 640
 641 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
 642   = return (RecordCon (L l c) noPostTcExpr fs)
 643 mkRecConstrOrUpdate exp loc fs@(_:_)
 644   = return (RecordUpd exp fs placeHolderType placeHolderType)
 645 mkRecConstrOrUpdate _ loc []
 646   = parseError loc "Empty record update"
 647
 648 -----------------------------------------------------------------------------
 649 -- utilities for foreign declarations
 650
 651 -- supported calling conventions
 652 --
 653 data CallConv = CCall  CCallConv        -- ccall or stdcall
 654               | DNCall                  -- .NET
 655
 656 -- construct a foreign import declaration
 657 --
 658 mkImport :: CallConv
 659          -> Safety
 660          -> (Located FastString, Located RdrName, LHsType RdrName)
 661          -> P (HsDecl RdrName)
 662 mkImport (CCall  cconv) safety (entity, v, ty) = do
 663   importSpec <- parseCImport entity cconv safety v
 664   return (ForD (ForeignImport v ty importSpec False))
 665 mkImport (DNCall      ) _      (entity, v, ty) = do
 666   spec <- parseDImport entity
 667   return $ ForD (ForeignImport v ty (DNImport spec) False)
 668
 669 -- parse the entity string of a foreign import declaration for the `ccall' or
 670 -- `stdcall' calling convention'
 671 --
 672 parseCImport :: Located FastString
 673              -> CCallConv
 674              -> Safety
 675              -> Located RdrName
 676              -> P ForeignImport
 677 parseCImport (L loc entity) cconv safety v
 678   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
 679   | entity == FSLIT ("dynamic") =
 680     return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
 681   | entity == FSLIT ("wrapper") =
 682     return $ CImport cconv safety nilFS nilFS CWrapper
 683   | otherwise                  = parse0 (unpackFS entity)
 684     where
 685       -- using the static keyword?
 686       parse0 (' ':                    rest) = parse0 rest
 687       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
 688       parse0                          rest  = parse1 rest
 689       -- check for header file name
 690       parse1     ""               = parse4 ""    nilFS        False nilFS
 691       parse1     (' ':rest)       = parse1 rest
 692       parse1 str@('&':_   )       = parse2 str   nilFS
 693       parse1 str@('[':_   )       = parse3 str   nilFS        False
 694       parse1 str
 695         | ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
 696         | otherwise               = parse4 str   nilFS        False nilFS
 697         where
 698           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
 699       -- check for address operator (indicating a label import)
 700       parse2     ""         header = parse4 ""   header False nilFS
 701       parse2     (' ':rest) header = parse2 rest header
 702       parse2     ('&':rest) header = parse3 rest header True
 703       parse2 str@('[':_   ) header = parse3 str  header False
 704       parse2 str            header = parse4 str  header False nilFS
 705       -- check for library object name
 706       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
 707       parse3 ('[':rest) header isLbl =
 708         case break (== ']') rest of
 709           (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
 710           _                         -> parseError loc "Missing ']' in entity"
 711       parse3 str        header isLbl = parse4 str  header isLbl nilFS
 712       -- check for name of C function
 713       parse4 ""         header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
 714       parse4 (' ':rest) header isLbl lib = parse4 rest                 header isLbl lib
 715       parse4 str        header isLbl lib
 716         | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
 717         | otherwise                      = parseError loc "Malformed entity string"
 718         where
 719           (first, rest) = break (== ' ') str
 720       --
 721       build cid header False lib = return $
 722         CImport cconv safety header lib (CFunction (StaticTarget cid))
 723       build cid header True  lib = return $
 724         CImport cconv safety header lib (CLabel                  cid )
 725
 726 --
 727 -- Unravel a dotnet spec string.
 728 --
 729 parseDImport :: Located FastString -> P DNCallSpec
 730 parseDImport (L loc entity) = parse0 comps
 731  where
 732   comps = words (unpackFS entity)
 733
 734   parse0 [] = d'oh
 735   parse0 (x : xs)
 736     | x == "static" = parse1 True xs
 737     | otherwise     = parse1 False (x:xs)
 738
 739   parse1 _ [] = d'oh
 740   parse1 isStatic (x:xs)
 741     | x == "method" = parse2 isStatic DNMethod xs
 742     | x == "field"  = parse2 isStatic DNField xs
 743     | x == "ctor"   = parse2 isStatic DNConstructor xs
 744   parse1 isStatic xs = parse2 isStatic DNMethod xs
 745
 746   parse2 _ _ [] = d'oh
 747   parse2 isStatic kind (('[':x):xs) =
 748      case x of
 749         [] -> d'oh
 750         vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
 751   parse2 isStatic kind xs = parse3 isStatic kind "" xs
 752
 753   parse3 isStatic kind assem [x] =
 754     return (DNCallSpec isStatic kind assem x
 755                           -- these will be filled in once known.
 756                         (error "FFI-dotnet-args")
 757                         (error "FFI-dotnet-result"))
 758   parse3 _ _ _ _ = d'oh
 759
 760   d'oh = parseError loc "Malformed entity string"
 761
 762 -- construct a foreign export declaration
 763 --
 764 mkExport :: CallConv
 765          -> (Located FastString, Located RdrName, LHsType RdrName)
 766          -> P (HsDecl RdrName)
 767 mkExport (CCall  cconv) (L loc entity, v, ty) = return $
 768   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
 769   where
 770     entity' | nullFastString entity = mkExtName (unLoc v)
 771             | otherwise             = entity
 772 mkExport DNCall (L loc entity, v, ty) =
 773   parseError (getLoc v){-TODO: not quite right-}
 774         "Foreign export is not yet supported for .NET"
 775
 776 -- Supplying the ext_name in a foreign decl is optional; if it
 777 -- isn't there, the Haskell name is assumed. Note that no transformation
 778 -- of the Haskell name is then performed, so if you foreign export (++),
 779 -- it's external name will be "++". Too bad; it's important because we don't
 780 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 781 -- (This is why we use occNameUserString.)
 782 --
 783 mkExtName :: RdrName -> CLabelString
 784 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
 785 \end{code}
 786
 787
 788 -----------------------------------------------------------------------------
 789 -- Misc utils
 790
 791 \begin{code}
 792 showRdrName :: RdrName -> String
 793 showRdrName r = showSDoc (ppr r)
 794
 795 parseError :: SrcSpan -> String -> P a
 796 parseError span s = failSpanMsgP span s
 797 \end{code}