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