compiler/parser/RdrHsSyn.lhs

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