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