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 -- We allow C,D :: ty
 820 -- and expand it as if it had been
 821 --    C :: ty; D :: ty
 822 -- (Just like type signatures in general.)
 823 mkGadtDecl names ty
 824   = [mk_gadt_con name qvars cxt tau | name <- names]
 825   where
 826     (qvars,cxt,tau) = case ty of
 827                         L _ (HsForAllTy _ qvars cxt tau) -> (qvars, cxt,      tau)
 828                         _                                -> ([],    noLoc [], ty)
 829
 830 mk_gadt_con :: Located RdrName
 831             -> [LHsTyVarBndr RdrName]
 832             -> LHsContext RdrName
 833             -> LHsType RdrName
 834             -> ConDecl RdrName
 835 mk_gadt_con name qvars cxt ty
 836   = ConDecl { con_name     = name
 837             , con_explicit = Implicit
 838             , con_qvars    = qvars
 839             , con_cxt      = cxt
 840             , con_details  = PrefixCon []
 841             , con_res      = ResTyGADT ty
 842             , con_doc      = Nothing }
 843   -- NB: we put the whole constr type into the ResTyGADT for now;
 844   -- the renamer will unravel it once it has sorted out
 845   -- operator fixities
 846
 847 -- A variable binding is parsed as a FunBind.
 848
 849
 850         -- The parser left-associates, so there should
 851         -- not be any OpApps inside the e's
 852 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
 853 -- Splits (f ! g a b) into (f, [(! g), a, b])
 854 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
 855   | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
 856   where
 857     (arg1,argns) = split_bang r_arg []
 858     split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
 859     split_bang e                 es = (e,es)
 860 splitBang _ = Nothing
 861
 862 isFunLhs :: LHsExpr RdrName
 863          -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
 864 -- Just (fun, is_infix, arg_pats) if e is a function LHS
 865 --
 866 -- The whole LHS is parsed as a single expression.
 867 -- Any infix operators on the LHS will parse left-associatively
 868 -- E.g.         f !x y !z
 869 --      will parse (rather strangely) as
 870 --              (f ! x y) ! z
 871 --      It's up to isFunLhs to sort out the mess
 872 --
 873 -- a .!. !b
 874
 875 isFunLhs e = go e []
 876  where
 877    go (L loc (HsVar f)) es
 878         | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
 879    go (L _ (HsApp f e)) es       = go f (e:es)
 880    go (L _ (HsPar e))   es@(_:_) = go e es
 881
 882         -- For infix function defns, there should be only one infix *function*
 883         -- (though there may be infix *datacons* involved too).  So we don't
 884         -- need fixity info to figure out which function is being defined.
 885         --      a `K1` b `op` c `K2` d
 886         -- must parse as
 887         --      (a `K1` b) `op` (c `K2` d)
 888         -- The renamer checks later that the precedences would yield such a parse.
 889         --
 890         -- There is a complication to deal with bang patterns.
 891         --
 892         -- ToDo: what about this?
 893         --              x + 1 `op` y = ...
 894
 895    go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
 896         | Just (e',es') <- splitBang e
 897         = do { bang_on <- extension bangPatEnabled
 898              ; if bang_on then go e' (es' ++ es)
 899                else return (Just (L loc' op, True, (l:r:es))) }
 900                 -- No bangs; behave just like the next case
 901         | not (isRdrDataCon op)         -- We have found the function!
 902         = return (Just (L loc' op, True, (l:r:es)))
 903         | otherwise                     -- Infix data con; keep going
 904         = do { mb_l <- go l es
 905              ; case mb_l of
 906                  Just (op', True, j : k : es')
 907                     -> return (Just (op', True, j : op_app : es'))
 908                     where
 909                       op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
 910                  _ -> return Nothing }
 911    go _ _ = return Nothing
 912
 913 ---------------------------------------------------------------------------
 914 -- Miscellaneous utilities
 915
 916 checkPrecP :: Located Int -> P Int
 917 checkPrecP (L l i)
 918  | 0 <= i && i <= maxPrecedence = return i
 919  | otherwise                    = parseError l "Precedence out of range"
 920
 921 mkRecConstrOrUpdate
 922         :: LHsExpr RdrName
 923         -> SrcSpan
 924         -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
 925         -> P (HsExpr RdrName)
 926
 927 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
 928   = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
 929 mkRecConstrOrUpdate exp loc (fs,dd)
 930   | null fs   = parseError loc "Empty record update"
 931   | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
 932
 933 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
 934 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
 935 mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
 936
 937 mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
 938 -- The Maybe is becuase the user can omit the activation spec (and usually does)
 939 mkInlineSpec Nothing    match_info True  = alwaysInlineSpec match_info
 940                                                                 -- INLINE
 941 mkInlineSpec Nothing    match_info False = neverInlineSpec  match_info
 942                                                                 -- NOINLINE
 943 mkInlineSpec (Just act) match_info inl   = Inline (InlinePragma act match_info) inl
 944
 945
 946 -----------------------------------------------------------------------------
 947 -- utilities for foreign declarations
 948
 949 -- supported calling conventions
 950 --
 951 data CallConv = CCall  CCallConv        -- ccall or stdcall
 952               | DNCall                  -- .NET
 953
 954 -- construct a foreign import declaration
 955 --
 956 mkImport :: CallConv
 957          -> Safety
 958          -> (Located FastString, Located RdrName, LHsType RdrName)
 959          -> P (HsDecl RdrName)
 960 mkImport (CCall  cconv) safety (entity, v, ty) = do
 961   importSpec <- parseCImport entity cconv safety v
 962   return (ForD (ForeignImport v ty importSpec))
 963 mkImport (DNCall      ) _      (entity, v, ty) = do
 964   spec <- parseDImport entity
 965   return $ ForD (ForeignImport v ty (DNImport spec))
 966
 967 -- parse the entity string of a foreign import declaration for the `ccall' or
 968 -- `stdcall' calling convention'
 969 --
 970 parseCImport :: Located FastString
 971              -> CCallConv
 972              -> Safety
 973              -> Located RdrName
 974              -> P ForeignImport
 975 parseCImport (L loc entity) cconv safety v
 976   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
 977   | entity == fsLit "dynamic" =
 978     return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
 979   | entity == fsLit "wrapper" =
 980     return $ CImport cconv safety nilFS nilFS CWrapper
 981   | otherwise                  = parse0 (unpackFS entity)
 982     where
 983       -- using the static keyword?
 984       parse0 (' ':                    rest) = parse0 rest
 985       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
 986       parse0                          rest  = parse1 rest
 987       -- check for header file name
 988       parse1     ""               = parse4 ""    nilFS        False nilFS
 989       parse1     (' ':rest)       = parse1 rest
 990       parse1 str@('&':_   )       = parse2 str   nilFS
 991       parse1 str@('[':_   )       = parse3 str   nilFS        False
 992       parse1 str
 993         | ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
 994         | otherwise               = parse4 str   nilFS        False nilFS
 995         where
 996           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
 997       -- check for address operator (indicating a label import)
 998       parse2     ""         header = parse4 ""   header False nilFS
 999       parse2     (' ':rest) header = parse2 rest header
1000       parse2     ('&':rest) header = parse3 rest header True
1001       parse2 str@('[':_   ) header = parse3 str  header False
1002       parse2 str            header = parse4 str  header False nilFS
1003       -- check for library object name
1004       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
1005       parse3 ('[':rest) header isLbl =
1006         case break (== ']') rest of
1007           (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
1008           _                         -> parseError loc "Missing ']' in entity"
1009       parse3 str        header isLbl = parse4 str  header isLbl nilFS
1010       -- check for name of C function
1011       parse4 ""         header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
1012       parse4 (' ':rest) header isLbl lib = parse4 rest                 header isLbl lib
1013       parse4 str        header isLbl lib
1014         | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
1015         | otherwise                      = parseError loc "Malformed entity string"
1016         where
1017           (first, rest) = break (== ' ') str
1018       --
1019       build cid header False lib = return $
1020         CImport cconv safety header lib (CFunction (StaticTarget cid))
1021       build cid header True  lib = return $
1022         CImport cconv safety header lib (CLabel                  cid )
1023
1024 --
1025 -- Unravel a dotnet spec string.
1026 --
1027 parseDImport :: Located FastString -> P DNCallSpec
1028 parseDImport (L loc entity) = parse0 comps
1029  where
1030   comps = words (unpackFS entity)
1031
1032   parse0 [] = d'oh
1033   parse0 (x : xs)
1034     | x == "static" = parse1 True xs
1035     | otherwise     = parse1 False (x:xs)
1036
1037   parse1 _ [] = d'oh
1038   parse1 isStatic (x:xs)
1039     | x == "method" = parse2 isStatic DNMethod xs
1040     | x == "field"  = parse2 isStatic DNField xs
1041     | x == "ctor"   = parse2 isStatic DNConstructor xs
1042   parse1 isStatic xs = parse2 isStatic DNMethod xs
1043
1044   parse2 _ _ [] = d'oh
1045   parse2 isStatic kind (('[':x):xs) =
1046      case x of
1047         [] -> d'oh
1048         vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
1049         _ -> d'oh
1050   parse2 isStatic kind xs = parse3 isStatic kind "" xs
1051
1052   parse3 isStatic kind assem [x] =
1053     return (DNCallSpec isStatic kind assem x
1054                           -- these will be filled in once known.
1055                         (error "FFI-dotnet-args")
1056                         (error "FFI-dotnet-result"))
1057   parse3 _ _ _ _ = d'oh
1058
1059   d'oh = parseError loc "Malformed entity string"
1060
1061 -- construct a foreign export declaration
1062 --
1063 mkExport :: CallConv
1064          -> (Located FastString, Located RdrName, LHsType RdrName)
1065          -> P (HsDecl RdrName)
1066 mkExport (CCall  cconv) (L _ entity, v, ty) = return $
1067   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1068   where
1069     entity' | nullFS entity = mkExtName (unLoc v)
1070             | otherwise     = entity
1071 mkExport DNCall (L _ _, v, _) =
1072   parseError (getLoc v){-TODO: not quite right-}
1073         "Foreign export is not yet supported for .NET"
1074
1075 -- Supplying the ext_name in a foreign decl is optional; if it
1076 -- isn't there, the Haskell name is assumed. Note that no transformation
1077 -- of the Haskell name is then performed, so if you foreign export (++),
1078 -- it's external name will be "++". Too bad; it's important because we don't
1079 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1080 --
1081 mkExtName :: RdrName -> CLabelString
1082 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1083 \end{code}
1084
1085
1086 -----------------------------------------------------------------------------
1087 -- Misc utils
1088
1089 \begin{code}
1090 parseError :: SrcSpan -> String -> P a
1091 parseError span s = parseErrorSDoc span (text s)
1092
1093 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1094 parseErrorSDoc span s = failSpanMsgP span s
1095 \end{code}