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