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       ( RecFlag(..), 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) -> HsBindGroup RdrName
 201 cvBindGroup binding
 202   = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
 203     HsBindGroup mbs sigs Recursive -- just one big group for now
 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 -- gaw 2004
 234 getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _))) binds
 235   | has_args mtchs
 236   = go mtchs loc binds
 237   where
 238     go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 (MatchGroup mtchs2 _))) : binds)
 239         | f == unLoc f2 = go (mtchs2++mtchs1) loc binds
 240         where loc = combineSrcSpans loc1 loc2
 241     go mtchs1 loc binds
 242         = (L loc (FunBind lf inf (mkMatchGroup (reverse mtchs1))), binds)
 243         -- reverse the final matches, to get it back in the right order
 244
 245 getMonoBind bind binds = (bind, binds)
 246
 247 has_args ((L _ (Match args _ _)) : _) = not (null args)
 248         -- Don't group together FunBinds if they have
 249         -- no arguments.  This is necessary now that variable bindings
 250         -- with no arguments are now treated as FunBinds rather
 251         -- than pattern bindings (tests/rename/should_fail/rnfail002).
 252 \end{code}
 253
 254 \begin{code}
 255 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 256 findSplice ds = addl oneEmptyBindGroup ds
 257
 258 mkGroup :: [LHsDecl a] -> HsGroup a
 259 mkGroup ds = addImpDecls oneEmptyBindGroup ds
 260
 261 oneEmptyBindGroup = emptyGroup{ hs_valds = [HsBindGroup emptyBag [] Recursive] }
 262
 263 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
 264 -- The decls are imported, and should not have a splice
 265 addImpDecls group decls = case addl group decls of
 266                                 (group', Nothing) -> group'
 267                                 other             -> panic "addImpDecls"
 268
 269 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 270         -- This stuff reverses the declarations (again) but it doesn't matter
 271
 272 -- Base cases
 273 addl gp []           = (gp, Nothing)
 274 addl gp (L l d : ds) = add gp l d ds
 275
 276
 277 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
 278   -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 279
 280 add gp l (SpliceD e) ds = (gp, Just (e, ds))
 281
 282 -- Class declarations: pull out the fixity signatures to the top
 283 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
 284         | isClassDecl d =
 285                 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
 286                 addl (gp { hs_tyclds = L l d : ts, hs_fixds  = fsigs ++ fs }) ds
 287         | otherwise =
 288                 addl (gp { hs_tyclds = L l d : ts }) ds
 289
 290 -- Signatures: fixity sigs go a different place than all others
 291 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
 292   = addl (gp {hs_fixds = L l f : ts}) ds
 293 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
 294   = addl (gp {hs_valds = add_sig (L l d) ts}) ds
 295
 296 -- Value declarations: use add_bind
 297 add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
 298   = addl (gp { hs_valds = add_bind (L l d) ts }) ds
 299
 300 -- The rest are routine
 301 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
 302   = addl (gp { hs_instds = L l d : ts }) ds
 303 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
 304   = addl (gp { hs_defds = L l d : ts }) ds
 305 add gp@(HsGroup {hs_fords  = ts})  l (ForD d) ds
 306   = addl (gp { hs_fords = L l d : ts }) ds
 307 add gp@(HsGroup {hs_depds  = ts})  l (DeprecD d) ds
 308   = addl (gp { hs_depds = L l d : ts }) ds
 309 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
 310   = addl (gp { hs_ruleds = L l d : ts }) ds
 311
 312 add_bind b [HsBindGroup bs sigs r] = [HsBindGroup (bs `snocBag` b) sigs     r]
 313 add_sig  s [HsBindGroup bs sigs r] = [HsBindGroup bs               (s:sigs) r]
 314 \end{code}
 315
 316 %************************************************************************
 317 %*                                                                      *
 318 \subsection[PrefixToHS-utils]{Utilities for conversion}
 319 %*                                                                      *
 320 %************************************************************************
 321
 322
 323 \begin{code}
 324 -----------------------------------------------------------------------------
 325 -- mkPrefixCon
 326
 327 -- When parsing data declarations, we sometimes inadvertently parse
 328 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
 329 -- This function splits up the type application, adds any pending
 330 -- arguments, and converts the type constructor back into a data constructor.
 331
 332 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
 333   -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
 334 mkPrefixCon ty tys
 335  = split ty tys
 336  where
 337    split (L _ (HsAppTy t u)) ts = split t (u : ts)
 338    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
 339                                      return (data_con, PrefixCon ts)
 340    split (L l _) _              = parseError l "parse error in data/newtype declaration"
 341
 342 mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
 343   -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
 344 mkRecCon (L loc con) fields
 345   = do data_con <- tyConToDataCon loc con
 346        return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
 347
 348 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 349 tyConToDataCon loc tc
 350   | isTcOcc (rdrNameOcc tc)
 351   = return (L loc (setRdrNameSpace tc srcDataName))
 352   | otherwise
 353   = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
 354
 355 ----------------------------------------------------------------------------
 356 -- Various Syntactic Checks
 357
 358 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
 359 checkInstType (L l t)
 360   = case t of
 361         HsForAllTy exp tvs ctxt ty -> do
 362                 dict_ty <- checkDictTy ty
 363                 return (L l (HsForAllTy exp tvs ctxt dict_ty))
 364
 365         HsParTy ty -> checkInstType ty
 366
 367         ty ->   do dict_ty <- checkDictTy (L l ty)
 368                    return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 369
 370 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
 371 checkTyVars tvs
 372   = mapM chk tvs
 373   where
 374         --  Check that the name space is correct!
 375     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
 376         | isRdrTyVar tv = return (L l (KindedTyVar tv k))
 377     chk (L l (HsTyVar tv))
 378         | isRdrTyVar tv = return (L l (UserTyVar tv))
 379     chk (L l other)
 380         = parseError l "Type found where type variable expected"
 381
 382 checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
 383 checkSynHdr ty = do { (_, tc, tvs) <- checkTyClHdr (noLoc []) ty
 384                     ; return (tc, tvs) }
 385
 386 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
 387   -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
 388 -- The header of a type or class decl should look like
 389 --      (C a, D b) => T a b
 390 -- or   T a b
 391 -- or   a + b
 392 -- etc
 393 checkTyClHdr (L l cxt) ty
 394   = do (tc, tvs) <- gol ty []
 395        mapM_ chk_pred cxt
 396        return (L l cxt, tc, tvs)
 397   where
 398     gol (L l ty) acc = go l ty acc
 399
 400     go l (HsTyVar tc)    acc
 401         | not (isRdrTyVar tc)   = checkTyVars acc               >>= \ tvs ->
 402                                   return (L l tc, tvs)
 403     go l (HsOpTy t1 tc t2) acc  = checkTyVars (t1:t2:acc)       >>= \ tvs ->
 404                                   return (tc, tvs)
 405     go l (HsParTy ty)    acc    = gol ty acc
 406     go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
 407     go l other           acc    = parseError l "Malformed LHS to type of class declaration"
 408
 409         -- The predicates in a type or class decl must all
 410         -- be HsClassPs.  They need not all be type variables,
 411         -- even in Haskell 98.  E.g. class (Monad m, Monad (t m)) => MonadT t m
 412     chk_pred (L l (HsClassP _ args)) = return ()
 413     chk_pred (L l _)
 414        = parseError l "Malformed context in type or class declaration"
 415
 416
 417 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 418 checkContext (L l t)
 419   = check t
 420  where
 421   check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
 422     = do ctx <- mapM checkPred ts
 423          return (L l ctx)
 424
 425   check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
 426     = check (unLoc ty)
 427
 428   check (HsTyVar t)     -- Empty context shows up as a unit type ()
 429     | t == getRdrName unitTyCon = return (L l [])
 430
 431   check t
 432     = do p <- checkPred (L l t)
 433          return (L l [p])
 434
 435
 436 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
 437 -- Watch out.. in ...deriving( Show )... we use checkPred on
 438 -- the list of partially applied predicates in the deriving,
 439 -- so there can be zero args.
 440 checkPred (L spn (HsPredTy (HsIParam n ty)))
 441   = return (L spn (HsIParam n ty))
 442 checkPred (L spn ty)
 443   = check spn ty []
 444   where
 445     checkl (L l ty) args = check l ty args
 446
 447     check _loc (HsTyVar t)             args | not (isRdrTyVar t)
 448                                             = return (L spn (HsClassP t args))
 449     check _loc (HsAppTy l r)           args = checkl l (r:args)
 450     check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
 451     check _loc (HsParTy t)             args = checkl t args
 452     check loc _                        _    = parseError loc  "malformed class assertion"
 453
 454 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
 455 checkDictTy (L spn ty) = check ty []
 456   where
 457   check (HsTyVar t) args | not (isRdrTyVar t)
 458         = return (L spn (HsPredTy (HsClassP t args)))
 459   check (HsAppTy l r) args = check (unLoc l) (r:args)
 460   check (HsParTy t)   args = check (unLoc t) args
 461   check _ _ = parseError spn "Malformed context in instance header"
 462
 463 ---------------------------------------------------------------------------
 464 -- Checking statements in a do-expression
 465 --      We parse   do { e1 ; e2 ; }
 466 --      as [ExprStmt e1, ExprStmt e2]
 467 -- checkDo (a) checks that the last thing is an ExprStmt
 468 --         (b) returns it separately
 469 -- same comments apply for mdo as well
 470
 471 checkDo  = checkDoMDo "a " "'do'"
 472 checkMDo = checkDoMDo "an " "'mdo'"
 473
 474 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
 475 checkDoMDo pre nm loc []   = parseError loc ("Empty " ++ nm ++ " construct")
 476 checkDoMDo pre nm loc ss   = do
 477   check ss
 478   where
 479         check  [L l (ExprStmt e _ _)] = return ([], e)
 480         check  [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
 481                                          " construct must be an expression")
 482         check (s:ss) = do
 483           (ss',e') <-  check ss
 484           return ((s:ss'),e')
 485
 486 -- -------------------------------------------------------------------------
 487 -- Checking Patterns.
 488
 489 -- We parse patterns as expressions and check for valid patterns below,
 490 -- converting the expression into a pattern at the same time.
 491
 492 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
 493 checkPattern e = checkLPat e
 494
 495 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
 496 checkPatterns es = mapM checkPattern es
 497
 498 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
 499 checkLPat e@(L l _) = checkPat l e []
 500
 501 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
 502 checkPat loc (L l (HsVar c)) args
 503   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
 504 checkPat loc (L _ (HsApp f x)) args = do
 505   x <- checkLPat x
 506   checkPat loc f (x:args)
 507 checkPat loc (L _ e) [] = do
 508   p <- checkAPat loc e
 509   return (L loc p)
 510 checkPat loc pat _some_args
 511   = patFail loc
 512
 513 checkAPat loc e = case e of
 514    EWildPat            -> return (WildPat placeHolderType)
 515    HsVar x | isQual x  -> parseError loc ("Qualified variable in pattern: "
 516                                          ++ showRdrName x)
 517            | otherwise -> return (VarPat x)
 518    HsLit l             -> return (LitPat l)
 519
 520    -- Overloaded numeric patterns (e.g. f 0 x = x)
 521    -- Negation is recorded separately, so that the literal is zero or +ve
 522    -- NB. Negative *primitive* literals are already handled by
 523    --     RdrHsSyn.mkHsNegApp
 524    HsOverLit pos_lit            -> return (mkNPat pos_lit Nothing)
 525    NegApp (L _ (HsOverLit pos_lit)) _
 526                         -> return (mkNPat pos_lit (Just noSyntaxExpr))
 527
 528    ELazyPat e      -> checkLPat e >>= (return . LazyPat)
 529    EAsPat n e      -> checkLPat e >>= (return . AsPat n)
 530    ExprWithTySig e t  -> checkLPat e >>= \e ->
 531                          -- Pattern signatures are parsed as sigtypes,
 532                          -- but they aren't explicit forall points.  Hence
 533                          -- we have to remove the implicit forall here.
 534                          let t' = case t of
 535                                      L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
 536                                      other -> other
 537                          in
 538                          return (SigPatIn e t')
 539
 540    -- n+k patterns
 541    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
 542         (L _ (HsOverLit lit@(HsIntegral _ _)))
 543                       | plus == plus_RDR
 544                       -> return (mkNPlusKPat (L nloc n) lit)
 545                       where
 546                          plus_RDR = mkUnqual varName FSLIT("+") -- Hack
 547
 548    OpApp l op fix r   -> checkLPat l >>= \l ->
 549                          checkLPat r >>= \r ->
 550                          case op of
 551                             L cl (HsVar c) | isDataOcc (rdrNameOcc c)
 552                                    -> return (ConPatIn (L cl c) (InfixCon l r))
 553                             _ -> patFail loc
 554
 555    HsPar e                 -> checkLPat e >>= (return . ParPat)
 556    ExplicitList _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
 557                          return (ListPat ps placeHolderType)
 558    ExplicitPArr _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
 559                          return (PArrPat ps placeHolderType)
 560
 561    ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
 562                          return (TuplePat ps b)
 563
 564    RecordCon c _ fs   -> mapM checkPatField fs >>= \fs ->
 565                          return (ConPatIn c (RecCon fs))
 566 -- Generics
 567    HsType ty          -> return (TypePat ty)
 568    _                  -> patFail loc
 569
 570 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
 571 checkPatField (n,e) = do
 572   p <- checkLPat e
 573   return (n,p)
 574
 575 patFail loc = parseError loc "Parse error in pattern"
 576
 577
 578 ---------------------------------------------------------------------------
 579 -- Check Equation Syntax
 580
 581 checkValDef
 582         :: LHsExpr RdrName
 583         -> Maybe (LHsType RdrName)
 584         -> Located (GRHSs RdrName)
 585         -> P (HsBind RdrName)
 586
 587 checkValDef lhs opt_sig (L rhs_span grhss)
 588   | Just (f,inf,es)  <- isFunLhs lhs []
 589   = if isQual (unLoc f)
 590         then parseError (getLoc f) ("Qualified name in function definition: "  ++
 591                                         showRdrName (unLoc f))
 592         else do ps <- checkPatterns es
 593                 let match_span = combineSrcSpans (getLoc lhs) rhs_span
 594                 return (FunBind f inf (mkMatchGroup [L match_span (Match ps opt_sig grhss)]))
 595         -- The span of the match covers the entire equation.
 596         -- That isn't quite right, but it'll do for now.
 597   | otherwise = do
 598         lhs <- checkPattern lhs
 599         return (PatBind lhs grhss placeHolderType)
 600
 601 checkValSig
 602         :: LHsExpr RdrName
 603         -> LHsType RdrName
 604         -> P (Sig RdrName)
 605 checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty)
 606 checkValSig (L l other)     ty
 607   = parseError l "Type signature given for an expression"
 608
 609 -- A variable binding is parsed as a FunBind.
 610
 611 isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
 612   -> Maybe (Located RdrName, Bool, [LHsExpr RdrName])
 613 isFunLhs (L loc e) = isFunLhs' loc e
 614  where
 615    isFunLhs' loc (HsVar f) es
 616         | not (isRdrDataCon f)          = Just (L loc f, False, es)
 617    isFunLhs' loc (HsApp f e) es         = isFunLhs f (e:es)
 618    isFunLhs' loc (HsPar e)   es@(_:_)   = isFunLhs e es
 619    isFunLhs' loc (OpApp l (L loc' (HsVar op)) fix r) es
 620         | not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es))
 621         | otherwise             =
 622                 case isFunLhs l es of
 623                     Just (op', True, j : k : es') ->
 624                       Just (op', True,
 625                             j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es')
 626                     _ -> Nothing
 627    isFunLhs' _ _ _ = Nothing
 628
 629 ---------------------------------------------------------------------------
 630 -- Miscellaneous utilities
 631
 632 checkPrecP :: Located Int -> P Int
 633 checkPrecP (L l i)
 634  | 0 <= i && i <= maxPrecedence = return i
 635  | otherwise                    = parseError l "Precedence out of range"
 636
 637 mkRecConstrOrUpdate
 638         :: LHsExpr RdrName
 639         -> SrcSpan
 640         -> HsRecordBinds RdrName
 641         -> P (HsExpr RdrName)
 642
 643 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
 644   = return (RecordCon (L l c) noPostTcExpr fs)
 645 mkRecConstrOrUpdate exp loc fs@(_:_)
 646   = return (RecordUpd exp fs placeHolderType placeHolderType)
 647 mkRecConstrOrUpdate _ loc []
 648   = parseError loc "Empty record update"
 649
 650 -----------------------------------------------------------------------------
 651 -- utilities for foreign declarations
 652
 653 -- supported calling conventions
 654 --
 655 data CallConv = CCall  CCallConv        -- ccall or stdcall
 656               | DNCall                  -- .NET
 657
 658 -- construct a foreign import declaration
 659 --
 660 mkImport :: CallConv
 661          -> Safety
 662          -> (Located FastString, Located RdrName, LHsType RdrName)
 663          -> P (HsDecl RdrName)
 664 mkImport (CCall  cconv) safety (entity, v, ty) = do
 665   importSpec <- parseCImport entity cconv safety v
 666   return (ForD (ForeignImport v ty importSpec False))
 667 mkImport (DNCall      ) _      (entity, v, ty) = do
 668   spec <- parseDImport entity
 669   return $ ForD (ForeignImport v ty (DNImport spec) False)
 670
 671 -- parse the entity string of a foreign import declaration for the `ccall' or
 672 -- `stdcall' calling convention'
 673 --
 674 parseCImport :: Located FastString
 675              -> CCallConv
 676              -> Safety
 677              -> Located RdrName
 678              -> P ForeignImport
 679 parseCImport (L loc entity) cconv safety v
 680   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
 681   | entity == FSLIT ("dynamic") =
 682     return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
 683   | entity == FSLIT ("wrapper") =
 684     return $ CImport cconv safety nilFS nilFS CWrapper
 685   | otherwise                  = parse0 (unpackFS entity)
 686     where
 687       -- using the static keyword?
 688       parse0 (' ':                    rest) = parse0 rest
 689       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
 690       parse0                          rest  = parse1 rest
 691       -- check for header file name
 692       parse1     ""               = parse4 ""    nilFS        False nilFS
 693       parse1     (' ':rest)       = parse1 rest
 694       parse1 str@('&':_   )       = parse2 str   nilFS
 695       parse1 str@('[':_   )       = parse3 str   nilFS        False
 696       parse1 str
 697         | ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
 698         | otherwise               = parse4 str   nilFS        False nilFS
 699         where
 700           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
 701       -- check for address operator (indicating a label import)
 702       parse2     ""         header = parse4 ""   header False nilFS
 703       parse2     (' ':rest) header = parse2 rest header
 704       parse2     ('&':rest) header = parse3 rest header True
 705       parse2 str@('[':_   ) header = parse3 str  header False
 706       parse2 str            header = parse4 str  header False nilFS
 707       -- check for library object name
 708       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
 709       parse3 ('[':rest) header isLbl =
 710         case break (== ']') rest of
 711           (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
 712           _                         -> parseError loc "Missing ']' in entity"
 713       parse3 str        header isLbl = parse4 str  header isLbl nilFS
 714       -- check for name of C function
 715       parse4 ""         header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
 716       parse4 (' ':rest) header isLbl lib = parse4 rest                 header isLbl lib
 717       parse4 str        header isLbl lib
 718         | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
 719         | otherwise                      = parseError loc "Malformed entity string"
 720         where
 721           (first, rest) = break (== ' ') str
 722       --
 723       build cid header False lib = return $
 724         CImport cconv safety header lib (CFunction (StaticTarget cid))
 725       build cid header True  lib = return $
 726         CImport cconv safety header lib (CLabel                  cid )
 727
 728 --
 729 -- Unravel a dotnet spec string.
 730 --
 731 parseDImport :: Located FastString -> P DNCallSpec
 732 parseDImport (L loc entity) = parse0 comps
 733  where
 734   comps = words (unpackFS entity)
 735
 736   parse0 [] = d'oh
 737   parse0 (x : xs)
 738     | x == "static" = parse1 True xs
 739     | otherwise     = parse1 False (x:xs)
 740
 741   parse1 _ [] = d'oh
 742   parse1 isStatic (x:xs)
 743     | x == "method" = parse2 isStatic DNMethod xs
 744     | x == "field"  = parse2 isStatic DNField xs
 745     | x == "ctor"   = parse2 isStatic DNConstructor xs
 746   parse1 isStatic xs = parse2 isStatic DNMethod xs
 747
 748   parse2 _ _ [] = d'oh
 749   parse2 isStatic kind (('[':x):xs) =
 750      case x of
 751         [] -> d'oh
 752         vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
 753   parse2 isStatic kind xs = parse3 isStatic kind "" xs
 754
 755   parse3 isStatic kind assem [x] =
 756     return (DNCallSpec isStatic kind assem x
 757                           -- these will be filled in once known.
 758                         (error "FFI-dotnet-args")
 759                         (error "FFI-dotnet-result"))
 760   parse3 _ _ _ _ = d'oh
 761
 762   d'oh = parseError loc "Malformed entity string"
 763
 764 -- construct a foreign export declaration
 765 --
 766 mkExport :: CallConv
 767          -> (Located FastString, Located RdrName, LHsType RdrName)
 768          -> P (HsDecl RdrName)
 769 mkExport (CCall  cconv) (L loc entity, v, ty) = return $
 770   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
 771   where
 772     entity' | nullFastString entity = mkExtName (unLoc v)
 773             | otherwise             = entity
 774 mkExport DNCall (L loc entity, v, ty) =
 775   parseError (getLoc v){-TODO: not quite right-}
 776         "Foreign export is not yet supported for .NET"
 777
 778 -- Supplying the ext_name in a foreign decl is optional; if it
 779 -- isn't there, the Haskell name is assumed. Note that no transformation
 780 -- of the Haskell name is then performed, so if you foreign export (++),
 781 -- it's external name will be "++". Too bad; it's important because we don't
 782 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 783 -- (This is why we use occNameUserString.)
 784 --
 785 mkExtName :: RdrName -> CLabelString
 786 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
 787 \end{code}
 788
 789
 790 -----------------------------------------------------------------------------
 791 -- Misc utils
 792
 793 \begin{code}
 794 showRdrName :: RdrName -> String
 795 showRdrName r = showSDoc (ppr r)
 796
 797 parseError :: SrcSpan -> String -> P a
 798 parseError span s = failSpanMsgP span s
 799 \end{code}