compiler/parser/RdrHsSyn.lhs

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