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