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