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