compiler/parser/RdrHsSyn.lhs

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