compiler/parser/RdrHsSyn.lhs

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