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