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