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,
  12         mkHsIntegral, mkHsFractional, mkHsIsString,
  13         mkHsDo, mkHsSplice, mkTopSpliceDecl,
  14         mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
  15         splitCon, mkInlinePragma,
  16         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
  17
  18         cvBindGroup,
  19         cvBindsAndSigs,
  20         cvTopDecls,
  21         placeHolderPunRhs,
  22
  23         -- Stuff to do with Foreign declarations
  24         mkImport,
  25         parseCImport,
  26         mkExport,
  27         mkExtName,           -- RdrName -> CLabelString
  28         mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
  29         mkSimpleConDecl,
  30         mkDeprecatedGadtRecordDecl,
  31
  32         -- Bunch of functions in the parser monad for
  33         -- checking and constructing values
  34         checkPrecP,           -- Int -> P Int
  35         checkContext,         -- HsType -> P HsContext
  36         checkPred,            -- HsType -> P HsPred
  37         checkTyVars,          -- [LHsType RdrName] -> P ()
  38         checkKindSigs,        -- [LTyClDecl RdrName] -> P ()
  39         checkInstType,        -- HsType -> P HsType
  40         checkPattern,         -- HsExp -> P HsPat
  41         bang_RDR,
  42         checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
  43         checkDo,              -- [Stmt] -> P [Stmt]
  44         checkMDo,             -- [Stmt] -> P [Stmt]
  45         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  46         checkValSig,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  47         parseError,
  48         parseErrorSDoc,
  49     ) where
  50
  51 import HsSyn            -- Lots of it
  52 import Class            ( FunDep )
  53 import TypeRep          ( Kind )
  54 import RdrName          ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
  55                           isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
  56 import BasicTypes       ( maxPrecedence, Activation(..), RuleMatchInfo,
  57                           InlinePragma(..) )
  58 import Lexer
  59 import TysWiredIn       ( unitTyCon )
  60 import ForeignCall
  61 import OccName          ( srcDataName, varName, isDataOcc, isTcOcc,
  62                           occNameString )
  63 import PrelNames        ( forall_tv_RDR )
  64 import DynFlags
  65 import SrcLoc
  66 import OrdList          ( OrdList, fromOL )
  67 import Bag              ( Bag, emptyBag, consBag, foldrBag )
  68 import Outputable
  69 import FastString
  70 import Maybes
  71
  72 import Control.Applicative ((<$>))
  73 import Text.ParserCombinators.ReadP as ReadP
  74 import Data.List        ( nubBy )
  75 import Data.Char
  76
  77 #include "HsVersions.h"
  78 \end{code}
  79
  80
  81 %************************************************************************
  82 %*                                                                      *
  83 \subsection{A few functions over HsSyn at RdrName}
  84 %*                                                                    *
  85 %************************************************************************
  86
  87 extractHsTyRdrNames finds the free variables of a HsType
  88 It's used when making the for-alls explicit.
  89
  90 \begin{code}
  91 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
  92 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
  93
  94 extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
  95 extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])
  96
  97 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
  98 -- This one takes the context and tau-part of a
  99 -- sigma type and returns their free type variables
 100 extractHsRhoRdrTyVars ctxt ty
 101  = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
 102
 103 extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
 104 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
 105
 106 extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
 107 extract_pred (HsClassP _   tys) acc = extract_ltys tys acc
 108 extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
 109 extract_pred (HsIParam _   ty ) acc = extract_lty ty acc
 110
 111 extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
 112 extract_ltys tys acc = foldr extract_lty acc tys
 113
 114 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
 115 extract_lty (L loc ty) acc
 116   = case ty of
 117       HsTyVar tv                -> extract_tv loc tv acc
 118       HsBangTy _ ty             -> extract_lty ty acc
 119       HsRecTy flds              -> foldr (extract_lty . cd_fld_type) acc flds
 120       HsAppTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
 121       HsListTy ty               -> extract_lty ty acc
 122       HsPArrTy ty               -> extract_lty ty acc
 123       HsTupleTy _ tys           -> extract_ltys tys acc
 124       HsFunTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
 125       HsPredTy p                -> extract_pred p acc
 126       HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
 127       HsParTy ty                -> extract_lty ty acc
 128       HsNumTy _                 -> acc
 129       HsQuasiQuoteTy {}         -> acc  -- Quasi quotes mention no type variables
 130       HsSpliceTy {}             -> acc  -- Type splices mention no type variables
 131       HsKindSig ty _            -> extract_lty ty acc
 132       HsForAllTy _ [] cx ty     -> extract_lctxt cx (extract_lty ty acc)
 133       HsForAllTy _ tvs cx ty    -> acc ++ (filter ((`notElem` locals) . unLoc) $
 134                                            extract_lctxt cx (extract_lty ty []))
 135                                 where
 136                                    locals = hsLTyVarNames tvs
 137       HsDocTy ty _              -> extract_lty ty acc
 138
 139 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
 140 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
 141                       | otherwise     = acc
 142
 143 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
 144 -- Get the type variables out of the type patterns in a bunch of
 145 -- possibly-generic bindings in a class declaration
 146 extractGenericPatTyVars binds
 147   = nubBy eqLocated (foldrBag get [] binds)
 148   where
 149     get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
 150     get _                                                 acc = acc
 151
 152     get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
 153     get_m _                                        acc = acc
 154 \end{code}
 155
 156
 157 %************************************************************************
 158 %*                                                                      *
 159 \subsection{Construction functions for Rdr stuff}
 160 %*                                                                    *
 161 %************************************************************************
 162
 163 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
 164 by deriving them from the name of the class.  We fill in the names for the
 165 tycon and datacon corresponding to the class, by deriving them from the
 166 name of the class itself.  This saves recording the names in the interface
 167 file (which would be equally good).
 168
 169 Similarly for mkConDecl, mkClassOpSig and default-method names.
 170
 171         *** See "THE NAMING STORY" in HsDecls ****
 172
 173 \begin{code}
 174 mkClassDecl :: SrcSpan
 175             -> Located (LHsContext RdrName, LHsType RdrName)
 176             -> Located [Located (FunDep RdrName)]
 177             -> Located (OrdList (LHsDecl RdrName))
 178             -> P (LTyClDecl RdrName)
 179
 180 mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls
 181   = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
 182        ; (cls, tparams) <- checkTyClHdr tycl_hdr
 183        ; tyvars <- checkTyVars tparams      -- Only type vars allowed
 184        ; checkKindSigs ats
 185        ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
 186                                     tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
 187                                     tcdATs   = ats, tcdDocs  = docs })) }
 188
 189 mkTyData :: SrcSpan
 190          -> NewOrData
 191          -> Bool                -- True <=> data family instance
 192          -> Located (LHsContext RdrName, LHsType RdrName)
 193          -> Maybe Kind
 194          -> [LConDecl RdrName]
 195          -> Maybe [LHsType RdrName]
 196          -> P (LTyClDecl RdrName)
 197 mkTyData loc new_or_data is_family (L _ (cxt, tycl_hdr)) ksig data_cons maybe_deriv
 198   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
 199
 200        ; (tyvars, typats) <- checkTParams is_family tparams
 201        ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
 202                                  tcdTyVars = tyvars, tcdTyPats = typats,
 203                                  tcdCons = data_cons,
 204                                  tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
 205
 206 mkTySynonym :: SrcSpan
 207             -> Bool             -- True <=> type family instances
 208             -> LHsType RdrName  -- LHS
 209             -> LHsType RdrName  -- RHS
 210             -> P (LTyClDecl RdrName)
 211 mkTySynonym loc is_family lhs rhs
 212   = do { (tc, tparams) <- checkTyClHdr lhs
 213        ; (tyvars, typats) <- checkTParams is_family tparams
 214        ; return (L loc (TySynonym tc tyvars typats rhs)) }
 215
 216 mkTyFamily :: SrcSpan
 217            -> FamilyFlavour
 218            -> LHsType RdrName   -- LHS
 219            -> Maybe Kind        -- Optional kind signature
 220            -> P (LTyClDecl RdrName)
 221 mkTyFamily loc flavour lhs ksig
 222   = do { (tc, tparams) <- checkTyClHdr lhs
 223        ; tyvars <- checkTyVars tparams
 224        ; return (L loc (TyFamily flavour tc tyvars ksig)) }
 225
 226 mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
 227 -- If the user wrote
 228 --      [pads| ... ]   then return a QuasiQuoteD
 229 --      $(e)           then return a SpliceD
 230 -- but if she wrote, say,
 231 --      f x            then behave as if she'd written $(f x)
 232 --                     ie a SpliceD
 233 mkTopSpliceDecl (L _ (HsQuasiQuoteE qq))            = QuasiQuoteD qq
 234 mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr)
 235 mkTopSpliceDecl other_expr                          = SpliceD (SpliceDecl other_expr)
 236 \end{code}
 237
 238 %************************************************************************
 239 %*                                                                      *
 240 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
 241 %*                                                                      *
 242 %************************************************************************
 243
 244 Function definitions are restructured here. Each is assumed to be recursive
 245 initially, and non recursive definitions are discovered by the dependency
 246 analyser.
 247
 248
 249 \begin{code}
 250 --  | Groups together bindings for a single function
 251 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
 252 cvTopDecls decls = go (fromOL decls)
 253   where
 254     go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
 255     go []                   = []
 256     go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'
 257                             where (L l' b', ds') = getMonoBind (L l b) ds
 258     go (d : ds)             = d : go ds
 259
 260 -- Declaration list may only contain value bindings and signatures.
 261 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
 262 cvBindGroup binding
 263   = case cvBindsAndSigs binding of
 264       (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
 265                                  ValBindsIn mbs sigs
 266
 267 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
 268   -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl])
 269 -- Input decls contain just value bindings and signatures
 270 -- and in case of class or instance declarations also
 271 -- associated type declarations. They might also contain Haddock comments.
 272 cvBindsAndSigs  fb = go (fromOL fb)
 273   where
 274     go []                  = (emptyBag, [], [], [])
 275     go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
 276                            where (bs, ss, ts, docs) = go ds
 277     go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
 278                            where (b', ds')    = getMonoBind (L l b) ds
 279                                  (bs, ss, ts, docs) = go ds'
 280     go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
 281                            where (bs, ss, ts, docs) = go ds
 282     go (L l (DocD d) : ds) =  (bs, ss, ts, (L l d) : docs)
 283                            where (bs, ss, ts, docs) = go ds
 284     go (L _ d : _)        = pprPanic "cvBindsAndSigs" (ppr d)
 285
 286 -----------------------------------------------------------------------------
 287 -- Group function bindings into equation groups
 288
 289 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
 290   -> (LHsBind RdrName, [LHsDecl RdrName])
 291 -- Suppose      (b',ds') = getMonoBind b ds
 292 --      ds is a list of parsed bindings
 293 --      b is a MonoBinds that has just been read off the front
 294
 295 -- Then b' is the result of grouping more equations from ds that
 296 -- belong with b into a single MonoBinds, and ds' is the depleted
 297 -- list of parsed bindings.
 298 --
 299 -- All Haddock comments between equations inside the group are
 300 -- discarded.
 301 --
 302 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 303
 304 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
 305                                fun_matches = MatchGroup mtchs1 _ })) binds
 306   | has_args mtchs1
 307   = go is_infix1 mtchs1 loc1 binds []
 308   where
 309     go is_infix mtchs loc
 310        (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
 311                                 fun_matches = MatchGroup mtchs2 _ })) : binds) _
 312         | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
 313                         (combineSrcSpans loc loc2) binds []
 314     go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
 315         = let doc_decls' = doc_decl : doc_decls
 316           in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
 317     go is_infix mtchs loc binds doc_decls
 318         = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
 319         -- Reverse the final matches, to get it back in the right order
 320         -- Do the same thing with the trailing doc comments
 321
 322 getMonoBind bind binds = (bind, binds)
 323
 324 has_args :: [LMatch RdrName] -> Bool
 325 has_args []                           = panic "RdrHsSyn:has_args"
 326 has_args ((L _ (Match args _ _)) : _) = not (null args)
 327         -- Don't group together FunBinds if they have
 328         -- no arguments.  This is necessary now that variable bindings
 329         -- with no arguments are now treated as FunBinds rather
 330         -- than pattern bindings (tests/rename/should_fail/rnfail002).
 331 \end{code}
 332
 333 %************************************************************************
 334 %*                                                                      *
 335 \subsection[PrefixToHS-utils]{Utilities for conversion}
 336 %*                                                                      *
 337 %************************************************************************
 338
 339
 340 \begin{code}
 341 -----------------------------------------------------------------------------
 342 -- splitCon
 343
 344 -- When parsing data declarations, we sometimes inadvertently parse
 345 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
 346 -- This function splits up the type application, adds any pending
 347 -- arguments, and converts the type constructor back into a data constructor.
 348
 349 splitCon :: LHsType RdrName
 350       -> P (Located RdrName, HsConDeclDetails RdrName)
 351 -- This gets given a "type" that should look like
 352 --      C Int Bool
 353 -- or   C { x::Int, y::Bool }
 354 -- and returns the pieces
 355 splitCon ty
 356  = split ty []
 357  where
 358    split (L _ (HsAppTy t u)) ts = split t (u : ts)
 359    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
 360                                      return (data_con, mk_rest ts)
 361    split (L l _) _              = parseError l "parse error in data/newtype declaration"
 362
 363    mk_rest [L _ (HsRecTy flds)] = RecCon flds
 364    mk_rest ts                   = PrefixCon ts
 365
 366 mkDeprecatedGadtRecordDecl :: SrcSpan
 367                            -> Located RdrName
 368                            -> [ConDeclField RdrName]
 369                            -> LHsType RdrName
 370                            ->  P (LConDecl  RdrName)
 371 -- This one uses the deprecated syntax
 372 --    C { x,y ::Int } :: T a b
 373 -- We give it a RecCon details right away
 374 mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
 375   = do { data_con <- tyConToDataCon con_loc con
 376        ; return (L loc (ConDecl { con_old_rec  = True
 377                                 , con_name     = data_con
 378                                 , con_explicit = Implicit
 379                                 , con_qvars    = []
 380                                 , con_cxt      = noLoc []
 381                                 , con_details  = RecCon flds
 382                                 , con_res      = ResTyGADT res_ty
 383                                 , con_doc      = Nothing })) }
 384
 385 mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
 386                 -> LHsContext RdrName -> HsConDeclDetails RdrName
 387                 -> ConDecl RdrName
 388
 389 mkSimpleConDecl name qvars cxt details
 390   = ConDecl { con_old_rec  = False
 391             , con_name     = name
 392             , con_explicit = Explicit
 393             , con_qvars    = qvars
 394             , con_cxt      = cxt
 395             , con_details  = details
 396             , con_res      = ResTyH98
 397             , con_doc      = Nothing }
 398
 399 mkGadtDecl :: [Located RdrName]
 400            -> LHsType RdrName     -- Always a HsForAllTy
 401            -> [ConDecl RdrName]
 402 -- We allow C,D :: ty
 403 -- and expand it as if it had been
 404 --    C :: ty; D :: ty
 405 -- (Just like type signatures in general.)
 406 mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
 407   = [mk_gadt_con name | name <- names]
 408   where
 409     (details, res_ty)           -- See Note [Sorting out the result type]
 410       = case tau of
 411           L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds,  res_ty)
 412           _other                                    -> (PrefixCon [], tau)
 413
 414     mk_gadt_con name
 415        = ConDecl { con_old_rec  = False
 416                  , con_name     = name
 417                  , con_explicit = imp
 418                  , con_qvars    = qvars
 419                  , con_cxt      = cxt
 420                  , con_details  = details
 421                  , con_res      = ResTyGADT res_ty
 422                  , con_doc      = Nothing }
 423 mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
 424
 425 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 426 tyConToDataCon loc tc
 427   | isTcOcc (rdrNameOcc tc)
 428   = return (L loc (setRdrNameSpace tc srcDataName))
 429   | otherwise
 430   = parseErrorSDoc loc (msg $$ extra)
 431   where
 432     msg = text "Not a data constructor:" <+> quotes (ppr tc)
 433     extra | tc == forall_tv_RDR
 434           = text "Perhaps you intended to use -XExistentialQuantification"
 435           | otherwise = empty
 436 \end{code}
 437
 438 Note [Sorting out the result type]
 439 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 440 In a GADT declaration which is not a record, we put the whole constr
 441 type into the ResTyGADT for now; the renamer will unravel it once it
 442 has sorted out operator fixities. Consider for example
 443      C :: a :*: b -> a :*: b -> a :+: b
 444 Initially this type will parse as
 445       a :*: (b -> (a :*: (b -> (a :+: b))))
 446
 447 so it's hard to split up the arguments until we've done the precedence
 448 resolution (in the renamer) On the other hand, for a record
 449         { x,y :: Int } -> a :*: b
 450 there is no doubt.  AND we need to sort records out so that
 451 we can bring x,y into scope.  So:
 452    * For PrefixCon we keep all the args in the ResTyGADT
 453    * For RecCon we do not
 454
 455 \begin{code}
 456 ----------------------------------------------------------------------------
 457 -- Various Syntactic Checks
 458
 459 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
 460 checkInstType (L l t)
 461   = case t of
 462         HsForAllTy exp tvs ctxt ty -> do
 463                 dict_ty <- checkDictTy ty
 464                 return (L l (HsForAllTy exp tvs ctxt dict_ty))
 465
 466         HsParTy ty -> checkInstType ty
 467
 468         ty ->   do dict_ty <- checkDictTy (L l ty)
 469                    return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 470
 471 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
 472 checkDictTy (L spn ty) = check ty []
 473   where
 474   check (HsTyVar tc)            args | isRdrTc tc = done tc args
 475   check (HsOpTy t1 (L _ tc) t2) args | isRdrTc tc = done tc (t1:t2:args)
 476   check (HsAppTy l r) args = check (unLoc l) (r:args)
 477   check (HsParTy t)   args = check (unLoc t) args
 478   check _ _ = parseError spn "Malformed instance header"
 479
 480   done tc args = return (L spn (HsPredTy (HsClassP tc args)))
 481
 482 checkTParams :: Bool      -- Type/data family
 483              -> [LHsType RdrName]
 484              -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
 485 -- checkTParams checks the type parameters of a data/newtype declaration
 486 -- There are two cases:
 487 --
 488 --  a) Vanilla data/newtype decl. In that case
 489 --        - the type parameters should all be type variables
 490 --        - they may have a kind annotation
 491 --
 492 --  b) Family data/newtype decl.  In that case
 493 --        - The type parameters may be arbitrary types
 494 --        - We find the type-varaible binders by find the
 495 --          free type vars of those types
 496 --        - We make them all kind-sig-free binders (UserTyVar)
 497 --          If there are kind sigs in the type parameters, they
 498 --          will fix the binder's kind when we kind-check the
 499 --          type parameters
 500 checkTParams is_family tparams
 501   | not is_family        -- Vanilla case (a)
 502   = do { tyvars <- checkTyVars tparams
 503        ; return (tyvars, Nothing) }
 504   | otherwise            -- Family case (b)
 505   = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams)
 506        ; return (tyvars, Just tparams) }
 507
 508 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
 509 -- Check whether the given list of type parameters are all type variables
 510 -- (possibly with a kind signature).  If the second argument is `False',
 511 -- only type variables are allowed and we raise an error on encountering a
 512 -- non-variable; otherwise, we allow non-variable arguments and return the
 513 -- entire list of parameters.
 514 checkTyVars tparms = mapM chk tparms
 515   where
 516         -- Check that the name space is correct!
 517     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
 518         | isRdrTyVar tv    = return (L l (KindedTyVar tv k))
 519     chk (L l (HsTyVar tv))
 520         | isRdrTyVar tv    = return (L l (UserTyVar tv placeHolderKind))
 521     chk (L l _)            =
 522           parseError l "Type found where type variable expected"
 523
 524 checkTyClHdr :: LHsType RdrName
 525              -> P (Located RdrName,          -- the head symbol (type or class name)
 526                    [LHsType RdrName])        -- parameters of head symbol
 527 -- Well-formedness check and decomposition of type and class heads.
 528 -- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
 529 --              Int :*: Bool   into    (:*:, [Int, Bool])
 530 -- returning the pieces
 531 checkTyClHdr ty
 532   = goL ty []
 533   where
 534     goL (L l ty) acc = go l ty acc
 535
 536     go l (HsTyVar tc) acc
 537         | isRdrTc tc         = return (L l tc, acc)
 538
 539     go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
 540         | isRdrTc tc         = return (ltc, t1:t2:acc)
 541     go _ (HsParTy ty)    acc = goL ty acc
 542     go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
 543     go l _               _   = parseError l "Malformed head of type or class declaration"
 544
 545 -- Check that associated type declarations of a class are all kind signatures.
 546 --
 547 checkKindSigs :: [LTyClDecl RdrName] -> P ()
 548 checkKindSigs = mapM_ check
 549   where
 550     check (L l tydecl)
 551       | isFamilyDecl tydecl
 552         || isSynDecl tydecl  = return ()
 553       | otherwise            =
 554         parseError l "Type declaration in a class must be a kind signature or synonym default"
 555
 556 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 557 checkContext (L l t)
 558   = check t
 559  where
 560   check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
 561     = do ctx <- mapM checkPred ts
 562          return (L l ctx)
 563
 564   check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
 565     = check (unLoc ty)
 566
 567   check (HsTyVar t)     -- Empty context shows up as a unit type ()
 568     | t == getRdrName unitTyCon = return (L l [])
 569
 570   check t
 571     = do p <- checkPred (L l t)
 572          return (L l [p])
 573
 574
 575 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
 576 -- Watch out.. in ...deriving( Show )... we use checkPred on
 577 -- the list of partially applied predicates in the deriving,
 578 -- so there can be zero args.
 579 checkPred (L spn (HsPredTy (HsIParam n ty)))
 580   = return (L spn (HsIParam n ty))
 581 checkPred (L spn ty)
 582   = check spn ty []
 583   where
 584     checkl (L l ty) args = check l ty args
 585
 586     check _loc (HsPredTy pred@(HsEqualP _ _))
 587                                        args | null args
 588                                             = return $ L spn pred
 589     check _loc (HsTyVar t)             args | not (isRdrTyVar t)
 590                                             = return (L spn (HsClassP t args))
 591     check _loc (HsAppTy l r)           args = checkl l (r:args)
 592     check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
 593     check _loc (HsParTy t)             args = checkl t args
 594     check loc _                        _    = parseError loc
 595                                                 "malformed class assertion"
 596
 597 ---------------------------------------------------------------------------
 598 -- Checking statements in a do-expression
 599 --      We parse   do { e1 ; e2 ; }
 600 --      as [ExprStmt e1, ExprStmt e2]
 601 -- checkDo (a) checks that the last thing is an ExprStmt
 602 --         (b) returns it separately
 603 -- same comments apply for mdo as well
 604
 605 checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
 606
 607 checkDo  = checkDoMDo "a " "'do'"
 608 checkMDo = checkDoMDo "an " "'mdo'"
 609
 610 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
 611 checkDoMDo _   nm loc []   = parseError loc ("Empty " ++ nm ++ " construct")
 612 checkDoMDo pre nm _   ss   = do
 613   check ss
 614   where
 615         check  []                     = panic "RdrHsSyn:checkDoMDo"
 616         check  [L _ (ExprStmt e _ _)] = return ([], e)
 617         check  [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
 618                                          " construct must be an expression")
 619         check (s:ss) = do
 620           (ss',e') <-  check ss
 621           return ((s:ss'),e')
 622
 623 -- -------------------------------------------------------------------------
 624 -- Checking Patterns.
 625
 626 -- We parse patterns as expressions and check for valid patterns below,
 627 -- converting the expression into a pattern at the same time.
 628
 629 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
 630 checkPattern e = checkLPat e
 631
 632 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
 633 checkPatterns es = mapM checkPattern es
 634
 635 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
 636 checkLPat e@(L l _) = checkPat l e []
 637
 638 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
 639 checkPat loc (L l (HsVar c)) args
 640   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
 641 checkPat loc e args     -- OK to let this happen even if bang-patterns
 642                         -- are not enabled, because there is no valid
 643                         -- non-bang-pattern parse of (C ! e)
 644   | Just (e', args') <- splitBang e
 645   = do  { args'' <- checkPatterns args'
 646         ; checkPat loc e' (args'' ++ args) }
 647 checkPat loc (L _ (HsApp f x)) args
 648   = do { x <- checkLPat x; checkPat loc f (x:args) }
 649 checkPat loc (L _ e) []
 650   = do { pState <- getPState
 651        ; p <- checkAPat (dflags pState) loc e
 652        ; return (L loc p) }
 653 checkPat loc _ _
 654   = patFail loc
 655
 656 checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
 657 checkAPat dynflags loc e = case e of
 658    EWildPat -> return (WildPat placeHolderType)
 659    HsVar x  -> return (VarPat x)
 660    HsLit l  -> return (LitPat l)
 661
 662    -- Overloaded numeric patterns (e.g. f 0 x = x)
 663    -- Negation is recorded separately, so that the literal is zero or +ve
 664    -- NB. Negative *primitive* literals are already handled by the lexer
 665    HsOverLit pos_lit          -> return (mkNPat pos_lit Nothing)
 666    NegApp (L _ (HsOverLit pos_lit)) _
 667                         -> return (mkNPat pos_lit (Just noSyntaxExpr))
 668
 669    SectionR (L _ (HsVar bang)) e        -- (! x)
 670         | bang == bang_RDR
 671         -> do { bang_on <- extension bangPatEnabled
 672               ; if bang_on then checkLPat e >>= (return . BangPat)
 673                 else parseError loc "Illegal bang-pattern (use -XBangPatterns)" }
 674
 675    ELazyPat e         -> checkLPat e >>= (return . LazyPat)
 676    EAsPat n e         -> checkLPat e >>= (return . AsPat n)
 677    -- view pattern is well-formed if the pattern is
 678    EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
 679    ExprWithTySig e t  -> do e <- checkLPat e
 680                             -- Pattern signatures are parsed as sigtypes,
 681                             -- but they aren't explicit forall points.  Hence
 682                             -- we have to remove the implicit forall here.
 683                             let t' = case t of
 684                                        L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
 685                                        other -> other
 686                             return (SigPatIn e t')
 687
 688    -- n+k patterns
 689    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
 690          (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
 691                       | dopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
 692                       -> return (mkNPlusKPat (L nloc n) lit)
 693
 694    OpApp l op _fix r  -> do l <- checkLPat l
 695                             r <- checkLPat r
 696                             case op of
 697                                L cl (HsVar c) | isDataOcc (rdrNameOcc c)
 698                                       -> return (ConPatIn (L cl c) (InfixCon l r))
 699                                _ -> patFail loc
 700
 701    HsPar e            -> checkLPat e >>= (return . ParPat)
 702    ExplicitList _ es  -> do ps <- mapM checkLPat es
 703                             return (ListPat ps placeHolderType)
 704    ExplicitPArr _ es  -> do ps <- mapM checkLPat es
 705                             return (PArrPat ps placeHolderType)
 706
 707    ExplicitTuple es b
 708      | all tupArgPresent es  -> do ps <- mapM checkLPat [e | Present e <- es]
 709                                    return (TuplePat ps b placeHolderType)
 710      | otherwise -> parseError loc "Illegal tuple section in pattern"
 711
 712    RecordCon c _ (HsRecFields fs dd)
 713                       -> do fs <- mapM checkPatField fs
 714                             return (ConPatIn c (RecCon (HsRecFields fs dd)))
 715    HsQuasiQuoteE q    -> return (QuasiQuotePat q)
 716 -- Generics
 717    HsType ty          -> return (TypePat ty)
 718    _                  -> patFail loc
 719
 720 placeHolderPunRhs :: LHsExpr RdrName
 721 -- The RHS of a punned record field will be filled in by the renamer
 722 -- It's better not to make it an error, in case we want to print it when debugging
 723 placeHolderPunRhs = noLoc (HsVar pun_RDR)
 724
 725 plus_RDR, bang_RDR, pun_RDR :: RdrName
 726 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
 727 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
 728 pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")
 729
 730 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
 731 checkPatField fld = do  { p <- checkLPat (hsRecFieldArg fld)
 732                         ; return (fld { hsRecFieldArg = p }) }
 733
 734 patFail :: SrcSpan -> P a
 735 patFail loc = parseError loc "Parse error in pattern"
 736
 737
 738 ---------------------------------------------------------------------------
 739 -- Check Equation Syntax
 740
 741 checkValDef :: LHsExpr RdrName
 742             -> Maybe (LHsType RdrName)
 743             -> Located (GRHSs RdrName)
 744             -> P (HsBind RdrName)
 745
 746 checkValDef lhs (Just sig) grhss
 747         -- x :: ty = rhs  parses as a *pattern* binding
 748   = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
 749
 750 checkValDef lhs opt_sig grhss
 751   = do  { mb_fun <- isFunLhs lhs
 752         ; case mb_fun of
 753             Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
 754                                                 fun is_infix pats opt_sig grhss
 755             Nothing -> checkPatBind lhs grhss }
 756
 757 checkFunBind :: SrcSpan
 758              -> Located RdrName
 759              -> Bool
 760              -> [LHsExpr RdrName]
 761              -> Maybe (LHsType RdrName)
 762              -> Located (GRHSs RdrName)
 763              -> P (HsBind RdrName)
 764 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
 765   = do  ps <- checkPatterns pats
 766         let match_span = combineSrcSpans lhs_loc rhs_span
 767         return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
 768         -- The span of the match covers the entire equation.
 769         -- That isn't quite right, but it'll do for now.
 770
 771 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
 772 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
 773 makeFunBind fn is_infix ms
 774   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
 775               fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
 776
 777 checkPatBind :: LHsExpr RdrName
 778              -> Located (GRHSs RdrName)
 779              -> P (HsBind RdrName)
 780 checkPatBind lhs (L _ grhss)
 781   = do  { lhs <- checkPattern lhs
 782         ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
 783
 784 checkValSig
 785         :: LHsExpr RdrName
 786         -> LHsType RdrName
 787         -> P (Sig RdrName)
 788 checkValSig (L l (HsVar v)) ty
 789   | isUnqual v && not (isDataOcc (rdrNameOcc v))
 790   = return (TypeSig (L l v) ty)
 791 checkValSig lhs@(L l _)         _
 792   | looks_like_foreign lhs
 793   = parseError l "Invalid type signature; perhaps you meant to use -XForeignFunctionInterface?"
 794   | otherwise
 795   = parseError l "Invalid type signature: should be of form <variable> :: <type>"
 796   where
 797     -- A common error is to forget the ForeignFunctionInterface flag
 798     -- so check for that, and suggest.  cf Trac #3805
 799     -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
 800     looks_like_foreign (L _ (HsVar v))     = v == foreign_RDR
 801     looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs
 802     looks_like_foreign _                   = False
 803
 804     foreign_RDR = mkUnqual varName (fsLit "foreign")
 805 \end{code}
 806
 807
 808 \begin{code}
 809         -- The parser left-associates, so there should
 810         -- not be any OpApps inside the e's
 811 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
 812 -- Splits (f ! g a b) into (f, [(! g), a, b])
 813 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
 814   | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
 815   where
 816     (arg1,argns) = split_bang r_arg []
 817     split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
 818     split_bang e                 es = (e,es)
 819 splitBang _ = Nothing
 820
 821 isFunLhs :: LHsExpr RdrName
 822          -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
 823 -- A variable binding is parsed as a FunBind.
 824 -- Just (fun, is_infix, arg_pats) if e is a function LHS
 825 --
 826 -- The whole LHS is parsed as a single expression.
 827 -- Any infix operators on the LHS will parse left-associatively
 828 -- E.g.         f !x y !z
 829 --      will parse (rather strangely) as
 830 --              (f ! x y) ! z
 831 --      It's up to isFunLhs to sort out the mess
 832 --
 833 -- a .!. !b
 834
 835 isFunLhs e = go e []
 836  where
 837    go (L loc (HsVar f)) es
 838         | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
 839    go (L _ (HsApp f e)) es       = go f (e:es)
 840    go (L _ (HsPar e))   es@(_:_) = go e es
 841
 842         -- For infix function defns, there should be only one infix *function*
 843         -- (though there may be infix *datacons* involved too).  So we don't
 844         -- need fixity info to figure out which function is being defined.
 845         --      a `K1` b `op` c `K2` d
 846         -- must parse as
 847         --      (a `K1` b) `op` (c `K2` d)
 848         -- The renamer checks later that the precedences would yield such a parse.
 849         --
 850         -- There is a complication to deal with bang patterns.
 851         --
 852         -- ToDo: what about this?
 853         --              x + 1 `op` y = ...
 854
 855    go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
 856         | Just (e',es') <- splitBang e
 857         = do { bang_on <- extension bangPatEnabled
 858              ; if bang_on then go e' (es' ++ es)
 859                else return (Just (L loc' op, True, (l:r:es))) }
 860                 -- No bangs; behave just like the next case
 861         | not (isRdrDataCon op)         -- We have found the function!
 862         = return (Just (L loc' op, True, (l:r:es)))
 863         | otherwise                     -- Infix data con; keep going
 864         = do { mb_l <- go l es
 865              ; case mb_l of
 866                  Just (op', True, j : k : es')
 867                     -> return (Just (op', True, j : op_app : es'))
 868                     where
 869                       op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
 870                  _ -> return Nothing }
 871    go _ _ = return Nothing
 872
 873 ---------------------------------------------------------------------------
 874 -- Miscellaneous utilities
 875
 876 checkPrecP :: Located Int -> P Int
 877 checkPrecP (L l i)
 878  | 0 <= i && i <= maxPrecedence = return i
 879  | otherwise                    = parseError l "Precedence out of range"
 880
 881 mkRecConstrOrUpdate
 882         :: LHsExpr RdrName
 883         -> SrcSpan
 884         -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
 885         -> P (HsExpr RdrName)
 886
 887 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
 888   = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
 889 mkRecConstrOrUpdate exp loc (fs,dd)
 890   | null fs   = parseError loc "Empty record update"
 891   | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
 892
 893 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
 894 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
 895 mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
 896
 897 mkInlinePragma :: Maybe Activation -> RuleMatchInfo -> Bool -> InlinePragma
 898 -- The Maybe is because the user can omit the activation spec (and usually does)
 899 mkInlinePragma mb_act match_info inl
 900   = InlinePragma { inl_inline = inl
 901                  , inl_sat    = Nothing
 902                  , inl_act    = act
 903                  , inl_rule   = match_info }
 904   where
 905     act = case mb_act of
 906             Just act -> act
 907             Nothing | inl       -> AlwaysActive
 908                     | otherwise -> NeverActive
 909         -- If no specific phase is given then:
 910         --   NOINLINE => NeverActive
 911         --   INLINE   => Active
 912
 913 -----------------------------------------------------------------------------
 914 -- utilities for foreign declarations
 915
 916 -- construct a foreign import declaration
 917 --
 918 mkImport :: CCallConv
 919          -> Safety
 920          -> (Located FastString, Located RdrName, LHsType RdrName)
 921          -> P (HsDecl RdrName)
 922 mkImport cconv safety (L loc entity, v, ty)
 923   | cconv == PrimCallConv                      = do
 924   let funcTarget = CFunction (StaticTarget entity Nothing)
 925       importSpec = CImport PrimCallConv safety nilFS funcTarget
 926   return (ForD (ForeignImport v ty importSpec))
 927
 928   | otherwise = do
 929     case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
 930       Nothing         -> parseError loc "Malformed entity string"
 931       Just importSpec -> return (ForD (ForeignImport v ty importSpec))
 932
 933 -- the string "foo" is ambigous: either a header or a C identifier.  The
 934 -- C identifier case comes first in the alternatives below, so we pick
 935 -- that one.
 936 parseCImport :: CCallConv -> Safety -> FastString -> String
 937              -> Maybe ForeignImport
 938 parseCImport cconv safety nm str =
 939  listToMaybe $ map fst $ filter (null.snd) $
 940      readP_to_S parse str
 941  where
 942    parse = do
 943        skipSpaces
 944        r <- choice [
 945           string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
 946           string "wrapper" >> return (mk nilFS CWrapper),
 947           optional (string "static" >> skipSpaces) >>
 948            (mk nilFS <$> cimp nm) +++
 949            (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
 950          ]
 951        skipSpaces
 952        return r
 953
 954    mk = CImport cconv safety
 955
 956    hdr_char c = not (isSpace c) -- header files are filenames, which can contain
 957                                 -- pretty much any char (depending on the platform),
 958                                 -- so just accept any non-space character
 959    id_char  c = isAlphaNum c || c == '_'
 960
 961    cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
 962              +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid)
 963           where
 964             cid = return nm +++
 965                   (do c  <- satisfy (\c -> isAlpha c || c == '_')
 966                       cs <-  many (satisfy id_char)
 967                       return (mkFastString (c:cs)))
 968
 969
 970 -- construct a foreign export declaration
 971 --
 972 mkExport :: CCallConv
 973          -> (Located FastString, Located RdrName, LHsType RdrName)
 974          -> P (HsDecl RdrName)
 975 mkExport cconv (L _ entity, v, ty) = return $
 976   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
 977   where
 978     entity' | nullFS entity = mkExtName (unLoc v)
 979             | otherwise     = entity
 980
 981 -- Supplying the ext_name in a foreign decl is optional; if it
 982 -- isn't there, the Haskell name is assumed. Note that no transformation
 983 -- of the Haskell name is then performed, so if you foreign export (++),
 984 -- it's external name will be "++". Too bad; it's important because we don't
 985 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 986 --
 987 mkExtName :: RdrName -> CLabelString
 988 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
 989 \end{code}
 990
 991
 992 -----------------------------------------------------------------------------
 993 -- Misc utils
 994
 995 \begin{code}
 996 parseError :: SrcSpan -> String -> P a
 997 parseError span s = parseErrorSDoc span (text s)
 998
 999 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1000 parseErrorSDoc span s = failSpanMsgP span s
1001 \end{code}