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