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 (1st arg serves as an accumulator)
 519     collect (L l (HsForAllTy _ _ _ _)) =
 520       const $ parseError l "Forall type not allowed as type parameter"
 521     collect (L l (HsTyVar tv))
 522       | isRdrTyVar tv                  = return . (L l (UserTyVar tv) :)
 523       | otherwise                      = return
 524     collect (L l (HsBangTy _ _      )) =
 525       const $ parseError l "Bang-style type annotations not allowed as type parameter"
 526     collect (L _ (HsAppTy t1 t2     )) = collect t2 >=> collect t1
 527     collect (L _ (HsFunTy t1 t2     )) = collect t2 >=> collect t1
 528     collect (L _ (HsListTy t        )) = collect t
 529     collect (L _ (HsPArrTy t        )) = collect t
 530     collect (L _ (HsTupleTy _ ts    )) = collects ts
 531     collect (L _ (HsOpTy t1 _ t2    )) = collect t2 >=> collect t1
 532     collect (L _ (HsParTy t         )) = collect t
 533     collect (L _ (HsNumTy _         )) = return
 534     collect (L l (HsPredTy _        )) =
 535       const $ parseError l "Predicate not allowed as type parameter"
 536     collect (L l (HsKindSig (L _ (HsTyVar tv)) k))
 537         | isRdrTyVar tv                =
 538           return . (L l (KindedTyVar tv k) :)
 539         | otherwise                    =
 540           const $ parseError l "Kind signature only allowed for type variables"
 541     collect (L l (HsSpliceTy _      )) =
 542       const $ parseError l "Splice not allowed as type parameter"
 543
 544         -- Collect all variables of a list of types
 545     collects []     = return
 546     collects (t:ts) = collects ts >=> collect t
 547
 548     (f >=> g) x = f x >>= g
 549
 550 -- Check that associated type declarations of a class are all kind signatures.
 551 --
 552 checkKindSigs :: [LTyClDecl RdrName] -> P ()
 553 checkKindSigs = mapM_ check
 554   where
 555     check (L l tydecl)
 556       | isFamilyDecl tydecl
 557         || isSynDecl tydecl  = return ()
 558       | otherwise            =
 559         parseError l "Type declaration in a class must be a kind signature or synonym default"
 560
 561 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 562 checkContext (L l t)
 563   = check t
 564  where
 565   check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
 566     = do ctx <- mapM checkPred ts
 567          return (L l ctx)
 568
 569   check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
 570     = check (unLoc ty)
 571
 572   check (HsTyVar t)     -- Empty context shows up as a unit type ()
 573     | t == getRdrName unitTyCon = return (L l [])
 574
 575   check t
 576     = do p <- checkPred (L l t)
 577          return (L l [p])
 578
 579
 580 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
 581 -- Watch out.. in ...deriving( Show )... we use checkPred on
 582 -- the list of partially applied predicates in the deriving,
 583 -- so there can be zero args.
 584 checkPred (L spn (HsPredTy (HsIParam n ty)))
 585   = return (L spn (HsIParam n ty))
 586 checkPred (L spn ty)
 587   = check spn ty []
 588   where
 589     checkl (L l ty) args = check l ty args
 590
 591     check _loc (HsPredTy pred@(HsEqualP _ _))
 592                                        args | null args
 593                                             = return $ L spn pred
 594     check _loc (HsTyVar t)             args | not (isRdrTyVar t)
 595                                             = return (L spn (HsClassP t args))
 596     check _loc (HsAppTy l r)           args = checkl l (r:args)
 597     check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
 598     check _loc (HsParTy t)             args = checkl t args
 599     check loc _                        _    = parseError loc
 600                                                 "malformed class assertion"
 601
 602 ---------------------------------------------------------------------------
 603 -- Checking stand-alone deriving declarations
 604
 605 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
 606 checkDerivDecl d@(L loc _) =
 607     do stDerivOn <- extension standaloneDerivingEnabled
 608        if stDerivOn then return d
 609          else parseError loc "Illegal stand-alone deriving declaration (use -XStandaloneDeriving)"
 610
 611 ---------------------------------------------------------------------------
 612 -- Checking statements in a do-expression
 613 --      We parse   do { e1 ; e2 ; }
 614 --      as [ExprStmt e1, ExprStmt e2]
 615 -- checkDo (a) checks that the last thing is an ExprStmt
 616 --         (b) returns it separately
 617 -- same comments apply for mdo as well
 618
 619 checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
 620
 621 checkDo  = checkDoMDo "a " "'do'"
 622 checkMDo = checkDoMDo "an " "'mdo'"
 623
 624 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
 625 checkDoMDo _   nm loc []   = parseError loc ("Empty " ++ nm ++ " construct")
 626 checkDoMDo pre nm _   ss   = do
 627   check ss
 628   where
 629         check  [L _ (ExprStmt e _ _)] = return ([], e)
 630         check  [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
 631                                          " construct must be an expression")
 632         check (s:ss) = do
 633           (ss',e') <-  check ss
 634           return ((s:ss'),e')
 635
 636 -- -------------------------------------------------------------------------
 637 -- Checking Patterns.
 638
 639 -- We parse patterns as expressions and check for valid patterns below,
 640 -- converting the expression into a pattern at the same time.
 641
 642 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
 643 checkPattern e = checkLPat e
 644
 645 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
 646 checkPatterns es = mapM checkPattern es
 647
 648 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
 649 checkLPat e@(L l _) = checkPat l e []
 650
 651 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
 652 checkPat loc (L l (HsVar c)) args
 653   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
 654 checkPat loc e args     -- OK to let this happen even if bang-patterns
 655                         -- are not enabled, because there is no valid
 656                         -- non-bang-pattern parse of (C ! e)
 657   | Just (e', args') <- splitBang e
 658   = do  { args'' <- checkPatterns args'
 659         ; checkPat loc e' (args'' ++ args) }
 660 checkPat loc (L _ (HsApp f x)) args
 661   = do { x <- checkLPat x; checkPat loc f (x:args) }
 662 checkPat loc (L _ e) []
 663   = do { p <- checkAPat loc e; return (L loc p) }
 664 checkPat loc _ _
 665   = patFail loc
 666
 667 checkAPat :: SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
 668 checkAPat loc e = case e of
 669    EWildPat            -> return (WildPat placeHolderType)
 670    HsVar x | isQual x  -> parseError loc ("Qualified variable in pattern: "
 671                                          ++ showRdrName x)
 672            | otherwise -> return (VarPat x)
 673    HsLit l             -> return (LitPat l)
 674
 675    -- Overloaded numeric patterns (e.g. f 0 x = x)
 676    -- Negation is recorded separately, so that the literal is zero or +ve
 677    -- NB. Negative *primitive* literals are already handled by the lexer
 678    HsOverLit pos_lit          -> return (mkNPat pos_lit Nothing)
 679    NegApp (L _ (HsOverLit pos_lit)) _
 680                         -> return (mkNPat pos_lit (Just noSyntaxExpr))
 681
 682    SectionR (L _ (HsVar bang)) e        -- (! x)
 683         | bang == bang_RDR
 684         -> do { bang_on <- extension bangPatEnabled
 685               ; if bang_on then checkLPat e >>= (return . BangPat)
 686                 else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
 687
 688    ELazyPat e         -> checkLPat e >>= (return . LazyPat)
 689    EAsPat n e         -> checkLPat e >>= (return . AsPat n)
 690    -- view pattern is well-formed if the pattern is
 691    EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
 692    ExprWithTySig e t  -> do e <- checkLPat e
 693                             -- Pattern signatures are parsed as sigtypes,
 694                             -- but they aren't explicit forall points.  Hence
 695                             -- we have to remove the implicit forall here.
 696                             let t' = case t of
 697                                        L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
 698                                        other -> other
 699                             return (SigPatIn e t')
 700
 701    -- n+k patterns
 702    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
 703         (L _ (HsOverLit lit@(HsIntegral _ _ _)))
 704                       | plus == plus_RDR
 705                       -> return (mkNPlusKPat (L nloc n) lit)
 706
 707    OpApp l op _fix r  -> do l <- checkLPat l
 708                             r <- checkLPat r
 709                             case op of
 710                                L cl (HsVar c) | isDataOcc (rdrNameOcc c)
 711                                       -> return (ConPatIn (L cl c) (InfixCon l r))
 712                                _ -> patFail loc
 713
 714    HsPar e            -> checkLPat e >>= (return . ParPat)
 715    ExplicitList _ es  -> do ps <- mapM checkLPat es
 716                             return (ListPat ps placeHolderType)
 717    ExplicitPArr _ es  -> do ps <- mapM checkLPat es
 718                             return (PArrPat ps placeHolderType)
 719
 720    ExplicitTuple es b -> do ps <- mapM checkLPat es
 721                             return (TuplePat ps b placeHolderType)
 722
 723    RecordCon c _ (HsRecFields fs dd)
 724                       -> do fs <- mapM checkPatField fs
 725                             return (ConPatIn c (RecCon (HsRecFields fs dd)))
 726    HsQuasiQuoteE q    -> return (QuasiQuotePat q)
 727 -- Generics
 728    HsType ty          -> return (TypePat ty)
 729    _                  -> patFail loc
 730
 731 plus_RDR, bang_RDR :: RdrName
 732 plus_RDR = mkUnqual varName FSLIT("+")  -- Hack
 733 bang_RDR = mkUnqual varName FSLIT("!")  -- Hack
 734
 735 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
 736 checkPatField fld = do  { p <- checkLPat (hsRecFieldArg fld)
 737                         ; return (fld { hsRecFieldArg = p }) }
 738
 739 patFail :: SrcSpan -> P a
 740 patFail loc = parseError loc "Parse error in pattern"
 741
 742
 743 ---------------------------------------------------------------------------
 744 -- Check Equation Syntax
 745
 746 checkValDef :: LHsExpr RdrName
 747             -> Maybe (LHsType RdrName)
 748             -> Located (GRHSs RdrName)
 749             -> P (HsBind RdrName)
 750
 751 checkValDef lhs (Just sig) grhss
 752         -- x :: ty = rhs  parses as a *pattern* binding
 753   = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
 754
 755 checkValDef lhs opt_sig grhss
 756   = do  { mb_fun <- isFunLhs lhs
 757         ; case mb_fun of
 758             Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
 759                                                 fun is_infix pats opt_sig grhss
 760             Nothing -> checkPatBind lhs grhss }
 761
 762 checkFunBind :: SrcSpan
 763              -> Located RdrName
 764              -> Bool
 765              -> [LHsExpr RdrName]
 766              -> Maybe (LHsType RdrName)
 767              -> Located (GRHSs RdrName)
 768              -> P (HsBind RdrName)
 769 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
 770   | isQual (unLoc fun)
 771   = parseError (getLoc fun) ("Qualified name in function definition: "  ++
 772                              showRdrName (unLoc fun))
 773   | otherwise
 774   = do  ps <- checkPatterns pats
 775         let match_span = combineSrcSpans lhs_loc rhs_span
 776         return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
 777         -- The span of the match covers the entire equation.
 778         -- That isn't quite right, but it'll do for now.
 779
 780 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
 781 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
 782 makeFunBind fn is_infix ms
 783   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
 784               fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
 785
 786 checkPatBind :: LHsExpr RdrName
 787              -> Located (GRHSs RdrName)
 788              -> P (HsBind RdrName)
 789 checkPatBind lhs (L _ grhss)
 790   = do  { lhs <- checkPattern lhs
 791         ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
 792
 793 checkValSig
 794         :: LHsExpr RdrName
 795         -> LHsType RdrName
 796         -> P (Sig RdrName)
 797 checkValSig (L l (HsVar v)) ty
 798   | isUnqual v && not (isDataOcc (rdrNameOcc v))
 799   = return (TypeSig (L l v) ty)
 800 checkValSig (L l _)         _
 801   = parseError l "Invalid type signature"
 802
 803 mkGadtDecl :: Located RdrName
 804            -> LHsType RdrName -- assuming HsType
 805            -> ConDecl RdrName
 806 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
 807 mkGadtDecl name ty                                = mk_gadt_con name [] (noLoc []) ty
 808
 809 mk_gadt_con :: Located RdrName
 810             -> [LHsTyVarBndr RdrName]
 811             -> LHsContext RdrName
 812             -> LHsType RdrName
 813             -> ConDecl RdrName
 814 mk_gadt_con name qvars cxt ty
 815   = ConDecl { con_name     = name
 816             , con_explicit = Implicit
 817             , con_qvars    = qvars
 818             , con_cxt      = cxt
 819             , con_details  = PrefixCon []
 820             , con_res      = ResTyGADT ty
 821             , con_doc      = Nothing }
 822   -- NB: we put the whole constr type into the ResTyGADT for now;
 823   -- the renamer will unravel it once it has sorted out
 824   -- operator fixities
 825
 826 -- A variable binding is parsed as a FunBind.
 827
 828
 829         -- The parser left-associates, so there should
 830         -- not be any OpApps inside the e's
 831 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
 832 -- Splits (f ! g a b) into (f, [(! g), a, b])
 833 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
 834   | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
 835   where
 836     (arg1,argns) = split_bang r_arg []
 837     split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
 838     split_bang e                 es = (e,es)
 839 splitBang _ = Nothing
 840
 841 isFunLhs :: LHsExpr RdrName
 842          -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
 843 -- Just (fun, is_infix, arg_pats) if e is a function LHS
 844 --
 845 -- The whole LHS is parsed as a single expression.
 846 -- Any infix operators on the LHS will parse left-associatively
 847 -- E.g.         f !x y !z
 848 --      will parse (rather strangely) as
 849 --              (f ! x y) ! z
 850 --      It's up to isFunLhs to sort out the mess
 851 --
 852 -- a .!. !b
 853
 854 isFunLhs e = go e []
 855  where
 856    go (L loc (HsVar f)) es
 857         | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
 858    go (L _ (HsApp f e)) es       = go f (e:es)
 859    go (L _ (HsPar e))   es@(_:_) = go e es
 860
 861         -- For infix function defns, there should be only one infix *function*
 862         -- (though there may be infix *datacons* involved too).  So we don't
 863         -- need fixity info to figure out which function is being defined.
 864         --      a `K1` b `op` c `K2` d
 865         -- must parse as
 866         --      (a `K1` b) `op` (c `K2` d)
 867         -- The renamer checks later that the precedences would yield such a parse.
 868         --
 869         -- There is a complication to deal with bang patterns.
 870         --
 871         -- ToDo: what about this?
 872         --              x + 1 `op` y = ...
 873
 874    go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
 875         | Just (e',es') <- splitBang e
 876         = do { bang_on <- extension bangPatEnabled
 877              ; if bang_on then go e' (es' ++ es)
 878                else return (Just (L loc' op, True, (l:r:es))) }
 879                 -- No bangs; behave just like the next case
 880         | not (isRdrDataCon op)         -- We have found the function!
 881         = return (Just (L loc' op, True, (l:r:es)))
 882         | otherwise                     -- Infix data con; keep going
 883         = do { mb_l <- go l es
 884              ; case mb_l of
 885                  Just (op', True, j : k : es')
 886                     -> return (Just (op', True, j : op_app : es'))
 887                     where
 888                       op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
 889                  _ -> return Nothing }
 890    go _ _ = return Nothing
 891
 892 ---------------------------------------------------------------------------
 893 -- Miscellaneous utilities
 894
 895 checkPrecP :: Located Int -> P Int
 896 checkPrecP (L l i)
 897  | 0 <= i && i <= maxPrecedence = return i
 898  | otherwise                    = parseError l "Precedence out of range"
 899
 900 mkRecConstrOrUpdate
 901         :: LHsExpr RdrName
 902         -> SrcSpan
 903         -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
 904         -> P (HsExpr RdrName)
 905
 906 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
 907   = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
 908 mkRecConstrOrUpdate exp loc (fs,dd)
 909   | null fs   = parseError loc "Empty record update"
 910   | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
 911
 912 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
 913 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
 914 mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
 915
 916 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
 917 -- The Maybe is becuase the user can omit the activation spec (and usually does)
 918 mkInlineSpec Nothing    True  = alwaysInlineSpec        -- INLINE
 919 mkInlineSpec Nothing    False = neverInlineSpec         -- NOINLINE
 920 mkInlineSpec (Just act) inl   = Inline act inl
 921
 922
 923 -----------------------------------------------------------------------------
 924 -- utilities for foreign declarations
 925
 926 -- supported calling conventions
 927 --
 928 data CallConv = CCall  CCallConv        -- ccall or stdcall
 929               | DNCall                  -- .NET
 930
 931 -- construct a foreign import declaration
 932 --
 933 mkImport :: CallConv
 934          -> Safety
 935          -> (Located FastString, Located RdrName, LHsType RdrName)
 936          -> P (HsDecl RdrName)
 937 mkImport (CCall  cconv) safety (entity, v, ty) = do
 938   importSpec <- parseCImport entity cconv safety v
 939   return (ForD (ForeignImport v ty importSpec))
 940 mkImport (DNCall      ) _      (entity, v, ty) = do
 941   spec <- parseDImport entity
 942   return $ ForD (ForeignImport v ty (DNImport spec))
 943
 944 -- parse the entity string of a foreign import declaration for the `ccall' or
 945 -- `stdcall' calling convention'
 946 --
 947 parseCImport :: Located FastString
 948              -> CCallConv
 949              -> Safety
 950              -> Located RdrName
 951              -> P ForeignImport
 952 parseCImport (L loc entity) cconv safety v
 953   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
 954   | entity == FSLIT ("dynamic") =
 955     return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
 956   | entity == FSLIT ("wrapper") =
 957     return $ CImport cconv safety nilFS nilFS CWrapper
 958   | otherwise                  = parse0 (unpackFS entity)
 959     where
 960       -- using the static keyword?
 961       parse0 (' ':                    rest) = parse0 rest
 962       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
 963       parse0                          rest  = parse1 rest
 964       -- check for header file name
 965       parse1     ""               = parse4 ""    nilFS        False nilFS
 966       parse1     (' ':rest)       = parse1 rest
 967       parse1 str@('&':_   )       = parse2 str   nilFS
 968       parse1 str@('[':_   )       = parse3 str   nilFS        False
 969       parse1 str
 970         | ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
 971         | otherwise               = parse4 str   nilFS        False nilFS
 972         where
 973           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
 974       -- check for address operator (indicating a label import)
 975       parse2     ""         header = parse4 ""   header False nilFS
 976       parse2     (' ':rest) header = parse2 rest header
 977       parse2     ('&':rest) header = parse3 rest header True
 978       parse2 str@('[':_   ) header = parse3 str  header False
 979       parse2 str            header = parse4 str  header False nilFS
 980       -- check for library object name
 981       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
 982       parse3 ('[':rest) header isLbl =
 983         case break (== ']') rest of
 984           (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
 985           _                         -> parseError loc "Missing ']' in entity"
 986       parse3 str        header isLbl = parse4 str  header isLbl nilFS
 987       -- check for name of C function
 988       parse4 ""         header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
 989       parse4 (' ':rest) header isLbl lib = parse4 rest                 header isLbl lib
 990       parse4 str        header isLbl lib
 991         | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
 992         | otherwise                      = parseError loc "Malformed entity string"
 993         where
 994           (first, rest) = break (== ' ') str
 995       --
 996       build cid header False lib = return $
 997         CImport cconv safety header lib (CFunction (StaticTarget cid))
 998       build cid header True  lib = return $
 999         CImport cconv safety header lib (CLabel                  cid )
1000
1001 --
1002 -- Unravel a dotnet spec string.
1003 --
1004 parseDImport :: Located FastString -> P DNCallSpec
1005 parseDImport (L loc entity) = parse0 comps
1006  where
1007   comps = words (unpackFS entity)
1008
1009   parse0 [] = d'oh
1010   parse0 (x : xs)
1011     | x == "static" = parse1 True xs
1012     | otherwise     = parse1 False (x:xs)
1013
1014   parse1 _ [] = d'oh
1015   parse1 isStatic (x:xs)
1016     | x == "method" = parse2 isStatic DNMethod xs
1017     | x == "field"  = parse2 isStatic DNField xs
1018     | x == "ctor"   = parse2 isStatic DNConstructor xs
1019   parse1 isStatic xs = parse2 isStatic DNMethod xs
1020
1021   parse2 _ _ [] = d'oh
1022   parse2 isStatic kind (('[':x):xs) =
1023      case x of
1024         [] -> d'oh
1025         vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
1026         _ -> d'oh
1027   parse2 isStatic kind xs = parse3 isStatic kind "" xs
1028
1029   parse3 isStatic kind assem [x] =
1030     return (DNCallSpec isStatic kind assem x
1031                           -- these will be filled in once known.
1032                         (error "FFI-dotnet-args")
1033                         (error "FFI-dotnet-result"))
1034   parse3 _ _ _ _ = d'oh
1035
1036   d'oh = parseError loc "Malformed entity string"
1037
1038 -- construct a foreign export declaration
1039 --
1040 mkExport :: CallConv
1041          -> (Located FastString, Located RdrName, LHsType RdrName)
1042          -> P (HsDecl RdrName)
1043 mkExport (CCall  cconv) (L _ entity, v, ty) = return $
1044   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1045   where
1046     entity' | nullFS entity = mkExtName (unLoc v)
1047             | otherwise     = entity
1048 mkExport DNCall (L _ _, v, _) =
1049   parseError (getLoc v){-TODO: not quite right-}
1050         "Foreign export is not yet supported for .NET"
1051
1052 -- Supplying the ext_name in a foreign decl is optional; if it
1053 -- isn't there, the Haskell name is assumed. Note that no transformation
1054 -- of the Haskell name is then performed, so if you foreign export (++),
1055 -- it's external name will be "++". Too bad; it's important because we don't
1056 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1057 --
1058 mkExtName :: RdrName -> CLabelString
1059 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1060 \end{code}
1061
1062
1063 -----------------------------------------------------------------------------
1064 -- Misc utils
1065
1066 \begin{code}
1067 showRdrName :: RdrName -> String
1068 showRdrName r = showSDoc (ppr r)
1069
1070 parseError :: SrcSpan -> String -> P a
1071 parseError span s = failSpanMsgP span s
1072 \end{code}