compiler/parser/RdrHsSyn.lhs

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