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