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