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