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, showRdrName )
  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_warnds  = ts})  l (WarningD d) ds
 351   = addl (gp { hs_warnds = L l d : ts }) ds
 352 add gp@(HsGroup {hs_annds  = ts}) l (AnnD d) ds
 353   = addl (gp { hs_annds = L l d : ts }) ds
 354 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
 355   = addl (gp { hs_ruleds = L l d : ts }) ds
 356
 357 add gp l (DocD d) ds
 358   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
 359
 360 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
 361 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
 362
 363 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
 364 add_sig  s (ValBindsIn bs sigs) = ValBindsIn bs               (s:sigs)
 365 \end{code}
 366
 367 %************************************************************************
 368 %*                                                                      *
 369 \subsection[PrefixToHS-utils]{Utilities for conversion}
 370 %*                                                                      *
 371 %************************************************************************
 372
 373
 374 \begin{code}
 375 -----------------------------------------------------------------------------
 376 -- mkPrefixCon
 377
 378 -- When parsing data declarations, we sometimes inadvertently parse
 379 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
 380 -- This function splits up the type application, adds any pending
 381 -- arguments, and converts the type constructor back into a data constructor.
 382
 383 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
 384             -> P (Located RdrName, HsConDeclDetails RdrName)
 385 mkPrefixCon ty tys
 386  = split ty tys
 387  where
 388    split (L _ (HsAppTy t u)) ts = split t (u : ts)
 389    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
 390                                      return (data_con, PrefixCon ts)
 391    split (L l _) _              = parseError l "parse error in data/newtype declaration"
 392
 393 mkRecCon :: Located RdrName ->
 394             [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
 395             P (Located RdrName, HsConDeclDetails RdrName)
 396 mkRecCon (L loc con) fields
 397   = do data_con <- tyConToDataCon loc con
 398        return (data_con, RecCon [ ConDeclField l t d | (ls, t, d) <- fields, l <- ls ])
 399
 400 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 401 tyConToDataCon loc tc
 402   | isTcOcc (rdrNameOcc tc)
 403   = return (L loc (setRdrNameSpace tc srcDataName))
 404   | otherwise
 405   = parseErrorSDoc loc (msg $$ extra)
 406   where
 407     msg = text "Not a data constructor:" <+> quotes (ppr tc)
 408     extra | tc == forall_tv_RDR
 409           = text "Perhaps you intended to use -XExistentialQuantification"
 410           | otherwise = empty
 411
 412 ----------------------------------------------------------------------------
 413 -- Various Syntactic Checks
 414
 415 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
 416 checkInstType (L l t)
 417   = case t of
 418         HsForAllTy exp tvs ctxt ty -> do
 419                 dict_ty <- checkDictTy ty
 420                 return (L l (HsForAllTy exp tvs ctxt dict_ty))
 421
 422         HsParTy ty -> checkInstType ty
 423
 424         ty ->   do dict_ty <- checkDictTy (L l ty)
 425                    return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 426
 427 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
 428 checkDictTy (L spn ty) = check ty []
 429   where
 430   check (HsTyVar t) args | not (isRdrTyVar t)
 431         = return (L spn (HsPredTy (HsClassP t args)))
 432   check (HsAppTy l r) args = check (unLoc l) (r:args)
 433   check (HsParTy t)   args = check (unLoc t) args
 434   check _ _ = parseError spn "Malformed instance header"
 435
 436 -- Check whether the given list of type parameters are all type variables
 437 -- (possibly with a kind signature).  If the second argument is `False',
 438 -- only type variables are allowed and we raise an error on encountering a
 439 -- non-variable; otherwise, we allow non-variable arguments and return the
 440 -- entire list of parameters.
 441 --
 442 checkTyVars :: [LHsType RdrName] -> P ()
 443 checkTyVars tparms = mapM_ chk tparms
 444   where
 445         -- Check that the name space is correct!
 446     chk (L _ (HsKindSig (L _ (HsTyVar tv)) _))
 447         | isRdrTyVar tv    = return ()
 448     chk (L _ (HsTyVar tv))
 449         | isRdrTyVar tv    = return ()
 450     chk (L l _)            =
 451           parseError l "Type found where type variable expected"
 452
 453 -- Check whether the type arguments in a type synonym head are simply
 454 -- variables.  If not, we have a type family instance and return all patterns.
 455 -- If yes, we return 'Nothing' as the third component to indicate a vanilla
 456 -- type synonym.
 457 --
 458 checkSynHdr :: LHsType RdrName
 459             -> Bool                             -- is type instance?
 460             -> P (Located RdrName,              -- head symbol
 461                   [LHsTyVarBndr RdrName],       -- parameters
 462                   [LHsType RdrName])            -- type patterns
 463 checkSynHdr ty isTyInst =
 464   do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
 465      ; unless isTyInst $ checkTyVars tparms
 466      ; return (tc, tvs, tparms) }
 467
 468
 469 -- Well-formedness check and decomposition of type and class heads.
 470 --
 471 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
 472   -> P (LHsContext RdrName,          -- the type context
 473         Located RdrName,             -- the head symbol (type or class name)
 474         [LHsTyVarBndr RdrName],      -- free variables of the non-context part
 475         [LHsType RdrName])           -- parameters of head symbol
 476 -- The header of a type or class decl should look like
 477 --      (C a, D b) => T a b
 478 -- or   T a b
 479 -- or   a + b
 480 -- etc
 481 -- With associated types, we can also have non-variable parameters; ie,
 482 --      T Int [a]
 483 -- or   Int :++: [a]
 484 -- The unaltered parameter list is returned in the fourth component of the
 485 -- result.  Eg, for
 486 --      T Int [a]
 487 -- we return
 488 --      ('()', 'T', ['a'], ['Int', '[a]'])
 489 checkTyClHdr (L l cxt) ty
 490   = do (tc, tvs, parms) <- gol ty []
 491        mapM_ chk_pred cxt
 492        return (L l cxt, tc, tvs, parms)
 493   where
 494     gol (L l ty) acc = go l ty acc
 495
 496     go l (HsTyVar tc) acc
 497         | isRdrTc tc            = do tvs <- extractTyVars acc
 498                                      return (L l tc, tvs, acc)
 499     go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
 500         | isRdrTc tc            = do tvs <- extractTyVars (t1:t2:acc)
 501                                      return (ltc, tvs, t1:t2:acc)
 502     go _ (HsParTy ty)    acc    = gol ty acc
 503     go _ (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
 504     go l _               _      =
 505       parseError l "Malformed head of type or class declaration"
 506
 507         -- The predicates in a type or class decl must be class predicates or
 508         -- equational constraints.  They need not all have variable-only
 509         -- arguments, even in Haskell 98.
 510         -- E.g. class (Monad m, Monad (t m)) => MonadT t m
 511     chk_pred (L _ (HsClassP _ _)) = return ()
 512     chk_pred (L _ (HsEqualP _ _)) = return ()
 513     chk_pred (L l _)
 514        = parseError l "Malformed context in type or class declaration"
 515
 516 -- Extract the type variables of a list of type parameters.
 517 --
 518 -- * Type arguments can be complex type terms (needed for associated type
 519 --   declarations).
 520 --
 521 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
 522 extractTyVars tvs = collects tvs []
 523   where
 524         -- Collect all variables (2nd arg serves as an accumulator)
 525     collect :: LHsType RdrName -> [LHsTyVarBndr RdrName]
 526                                -> P [LHsTyVarBndr RdrName]
 527     collect (L l (HsForAllTy _ _ _ _)) =
 528       const $ parseError l "Forall type not allowed as type parameter"
 529     collect (L l (HsTyVar tv))
 530       | isRdrTyVar tv                  = return . (L l (UserTyVar tv) :)
 531       | otherwise                      = return
 532     collect (L l (HsBangTy _ _      )) =
 533       const $ parseError l "Bang-style type annotations not allowed as type parameter"
 534     collect (L _ (HsAppTy t1 t2     )) = collect t2 >=> collect t1
 535     collect (L _ (HsFunTy t1 t2     )) = collect t2 >=> collect t1
 536     collect (L _ (HsListTy t        )) = collect t
 537     collect (L _ (HsPArrTy t        )) = collect t
 538     collect (L _ (HsTupleTy _ ts    )) = collects ts
 539     collect (L _ (HsOpTy t1 _ t2    )) = collect t2 >=> collect t1
 540     collect (L _ (HsParTy t         )) = collect t
 541     collect (L _ (HsNumTy _         )) = return
 542     collect (L l (HsPredTy _        )) =
 543       const $ parseError l "Predicate not allowed as type parameter"
 544     collect (L l (HsKindSig (L _ (HsTyVar tv)) k))
 545         | isRdrTyVar tv                =
 546           return . (L l (KindedTyVar tv k) :)
 547         | otherwise                    =
 548           const $ parseError l "Kind signature only allowed for type variables"
 549     collect (L l (HsSpliceTy _      )) =
 550       const $ parseError l "Splice not allowed as type parameter"
 551
 552         -- Collect all variables of a list of types
 553     collects []     = return
 554     collects (t:ts) = collects ts >=> collect t
 555
 556     (f >=> g) x = f x >>= g
 557
 558 -- Check that associated type declarations of a class are all kind signatures.
 559 --
 560 checkKindSigs :: [LTyClDecl RdrName] -> P ()
 561 checkKindSigs = mapM_ check
 562   where
 563     check (L l tydecl)
 564       | isFamilyDecl tydecl
 565         || isSynDecl tydecl  = return ()
 566       | otherwise            =
 567         parseError l "Type declaration in a class must be a kind signature or synonym default"
 568
 569 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 570 checkContext (L l t)
 571   = check t
 572  where
 573   check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
 574     = do ctx <- mapM checkPred ts
 575          return (L l ctx)
 576
 577   check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
 578     = check (unLoc ty)
 579
 580   check (HsTyVar t)     -- Empty context shows up as a unit type ()
 581     | t == getRdrName unitTyCon = return (L l [])
 582
 583   check t
 584     = do p <- checkPred (L l t)
 585          return (L l [p])
 586
 587
 588 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
 589 -- Watch out.. in ...deriving( Show )... we use checkPred on
 590 -- the list of partially applied predicates in the deriving,
 591 -- so there can be zero args.
 592 checkPred (L spn (HsPredTy (HsIParam n ty)))
 593   = return (L spn (HsIParam n ty))
 594 checkPred (L spn ty)
 595   = check spn ty []
 596   where
 597     checkl (L l ty) args = check l ty args
 598
 599     check _loc (HsPredTy pred@(HsEqualP _ _))
 600                                        args | null args
 601                                             = return $ L spn pred
 602     check _loc (HsTyVar t)             args | not (isRdrTyVar t)
 603                                             = return (L spn (HsClassP t args))
 604     check _loc (HsAppTy l r)           args = checkl l (r:args)
 605     check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
 606     check _loc (HsParTy t)             args = checkl t args
 607     check loc _                        _    = parseError loc
 608                                                 "malformed class assertion"
 609
 610 ---------------------------------------------------------------------------
 611 -- Checking stand-alone deriving declarations
 612
 613 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
 614 checkDerivDecl d@(L loc _) =
 615     do stDerivOn <- extension standaloneDerivingEnabled
 616        if stDerivOn then return d
 617          else parseError loc "Illegal stand-alone deriving declaration (use -XStandaloneDeriving)"
 618
 619 ---------------------------------------------------------------------------
 620 -- Checking statements in a do-expression
 621 --      We parse   do { e1 ; e2 ; }
 622 --      as [ExprStmt e1, ExprStmt e2]
 623 -- checkDo (a) checks that the last thing is an ExprStmt
 624 --         (b) returns it separately
 625 -- same comments apply for mdo as well
 626
 627 checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
 628
 629 checkDo  = checkDoMDo "a " "'do'"
 630 checkMDo = checkDoMDo "an " "'mdo'"
 631
 632 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
 633 checkDoMDo _   nm loc []   = parseError loc ("Empty " ++ nm ++ " construct")
 634 checkDoMDo pre nm _   ss   = do
 635   check ss
 636   where
 637         check  [L _ (ExprStmt e _ _)] = return ([], e)
 638         check  [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
 639                                          " construct must be an expression")
 640         check (s:ss) = do
 641           (ss',e') <-  check ss
 642           return ((s:ss'),e')
 643
 644 -- -------------------------------------------------------------------------
 645 -- Checking Patterns.
 646
 647 -- We parse patterns as expressions and check for valid patterns below,
 648 -- converting the expression into a pattern at the same time.
 649
 650 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
 651 checkPattern e = checkLPat e
 652
 653 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
 654 checkPatterns es = mapM checkPattern es
 655
 656 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
 657 checkLPat e@(L l _) = checkPat l e []
 658
 659 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
 660 checkPat loc (L l (HsVar c)) args
 661   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
 662 checkPat loc e args     -- OK to let this happen even if bang-patterns
 663                         -- are not enabled, because there is no valid
 664                         -- non-bang-pattern parse of (C ! e)
 665   | Just (e', args') <- splitBang e
 666   = do  { args'' <- checkPatterns args'
 667         ; checkPat loc e' (args'' ++ args) }
 668 checkPat loc (L _ (HsApp f x)) args
 669   = do { x <- checkLPat x; checkPat loc f (x:args) }
 670 checkPat loc (L _ e) []
 671   = do { p <- checkAPat loc e; return (L loc p) }
 672 checkPat loc _ _
 673   = patFail loc
 674
 675 checkAPat :: SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
 676 checkAPat loc e = case e of
 677    EWildPat            -> return (WildPat placeHolderType)
 678    HsVar x | isQual x  -> parseError loc ("Qualified variable in pattern: "
 679                                          ++ showRdrName x)
 680            | otherwise -> return (VarPat x)
 681    HsLit l             -> return (LitPat l)
 682
 683    -- Overloaded numeric patterns (e.g. f 0 x = x)
 684    -- Negation is recorded separately, so that the literal is zero or +ve
 685    -- NB. Negative *primitive* literals are already handled by the lexer
 686    HsOverLit pos_lit          -> return (mkNPat pos_lit Nothing)
 687    NegApp (L _ (HsOverLit pos_lit)) _
 688                         -> return (mkNPat pos_lit (Just noSyntaxExpr))
 689
 690    SectionR (L _ (HsVar bang)) e        -- (! x)
 691         | bang == bang_RDR
 692         -> do { bang_on <- extension bangPatEnabled
 693               ; if bang_on then checkLPat e >>= (return . BangPat)
 694                 else parseError loc "Illegal bang-pattern (use -XBangPatterns)" }
 695
 696    ELazyPat e         -> checkLPat e >>= (return . LazyPat)
 697    EAsPat n e         -> checkLPat e >>= (return . AsPat n)
 698    -- view pattern is well-formed if the pattern is
 699    EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
 700    ExprWithTySig e t  -> do e <- checkLPat e
 701                             -- Pattern signatures are parsed as sigtypes,
 702                             -- but they aren't explicit forall points.  Hence
 703                             -- we have to remove the implicit forall here.
 704                             let t' = case t of
 705                                        L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
 706                                        other -> other
 707                             return (SigPatIn e t')
 708
 709    -- n+k patterns
 710    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
 711          (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
 712                       | plus == plus_RDR
 713                       -> return (mkNPlusKPat (L nloc n) lit)
 714
 715    OpApp l op _fix r  -> do l <- checkLPat l
 716                             r <- checkLPat r
 717                             case op of
 718                                L cl (HsVar c) | isDataOcc (rdrNameOcc c)
 719                                       -> return (ConPatIn (L cl c) (InfixCon l r))
 720                                _ -> patFail loc
 721
 722    HsPar e            -> checkLPat e >>= (return . ParPat)
 723    ExplicitList _ es  -> do ps <- mapM checkLPat es
 724                             return (ListPat ps placeHolderType)
 725    ExplicitPArr _ es  -> do ps <- mapM checkLPat es
 726                             return (PArrPat ps placeHolderType)
 727
 728    ExplicitTuple es b -> do ps <- mapM checkLPat es
 729                             return (TuplePat ps b placeHolderType)
 730
 731    RecordCon c _ (HsRecFields fs dd)
 732                       -> do fs <- mapM checkPatField fs
 733                             return (ConPatIn c (RecCon (HsRecFields fs dd)))
 734    HsQuasiQuoteE q    -> return (QuasiQuotePat q)
 735 -- Generics
 736    HsType ty          -> return (TypePat ty)
 737    _                  -> patFail loc
 738
 739 plus_RDR, bang_RDR :: RdrName
 740 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
 741 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
 742
 743 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
 744 checkPatField fld = do  { p <- checkLPat (hsRecFieldArg fld)
 745                         ; return (fld { hsRecFieldArg = p }) }
 746
 747 patFail :: SrcSpan -> P a
 748 patFail loc = parseError loc "Parse error in pattern"
 749
 750
 751 ---------------------------------------------------------------------------
 752 -- Check Equation Syntax
 753
 754 checkValDef :: LHsExpr RdrName
 755             -> Maybe (LHsType RdrName)
 756             -> Located (GRHSs RdrName)
 757             -> P (HsBind RdrName)
 758
 759 checkValDef lhs (Just sig) grhss
 760         -- x :: ty = rhs  parses as a *pattern* binding
 761   = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
 762
 763 checkValDef lhs opt_sig grhss
 764   = do  { mb_fun <- isFunLhs lhs
 765         ; case mb_fun of
 766             Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
 767                                                 fun is_infix pats opt_sig grhss
 768             Nothing -> checkPatBind lhs grhss }
 769
 770 checkFunBind :: SrcSpan
 771              -> Located RdrName
 772              -> Bool
 773              -> [LHsExpr RdrName]
 774              -> Maybe (LHsType RdrName)
 775              -> Located (GRHSs RdrName)
 776              -> P (HsBind RdrName)
 777 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
 778   | isQual (unLoc fun)
 779   = parseErrorSDoc (getLoc fun)
 780         (ptext (sLit "Qualified name in function definition:") <+> ppr (unLoc fun))
 781   | otherwise
 782   = do  ps <- checkPatterns pats
 783         let match_span = combineSrcSpans lhs_loc rhs_span
 784         return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
 785         -- The span of the match covers the entire equation.
 786         -- That isn't quite right, but it'll do for now.
 787
 788 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
 789 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
 790 makeFunBind fn is_infix ms
 791   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
 792               fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
 793
 794 checkPatBind :: LHsExpr RdrName
 795              -> Located (GRHSs RdrName)
 796              -> P (HsBind RdrName)
 797 checkPatBind lhs (L _ grhss)
 798   = do  { lhs <- checkPattern lhs
 799         ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
 800
 801 checkValSig
 802         :: LHsExpr RdrName
 803         -> LHsType RdrName
 804         -> P (Sig RdrName)
 805 checkValSig (L l (HsVar v)) ty
 806   | isUnqual v && not (isDataOcc (rdrNameOcc v))
 807   = return (TypeSig (L l v) ty)
 808 checkValSig (L l _)         _
 809   = parseError l "Invalid type signature"
 810
 811 mkGadtDecl :: Located RdrName
 812            -> LHsType RdrName -- assuming HsType
 813            -> ConDecl RdrName
 814 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
 815 mkGadtDecl name ty                                = mk_gadt_con name [] (noLoc []) ty
 816
 817 mk_gadt_con :: Located RdrName
 818             -> [LHsTyVarBndr RdrName]
 819             -> LHsContext RdrName
 820             -> LHsType RdrName
 821             -> ConDecl RdrName
 822 mk_gadt_con name qvars cxt ty
 823   = ConDecl { con_name     = name
 824             , con_explicit = Implicit
 825             , con_qvars    = qvars
 826             , con_cxt      = cxt
 827             , con_details  = PrefixCon []
 828             , con_res      = ResTyGADT ty
 829             , con_doc      = Nothing }
 830   -- NB: we put the whole constr type into the ResTyGADT for now;
 831   -- the renamer will unravel it once it has sorted out
 832   -- operator fixities
 833
 834 -- A variable binding is parsed as a FunBind.
 835
 836
 837         -- The parser left-associates, so there should
 838         -- not be any OpApps inside the e's
 839 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
 840 -- Splits (f ! g a b) into (f, [(! g), a, b])
 841 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
 842   | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
 843   where
 844     (arg1,argns) = split_bang r_arg []
 845     split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
 846     split_bang e                 es = (e,es)
 847 splitBang _ = Nothing
 848
 849 isFunLhs :: LHsExpr RdrName
 850          -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
 851 -- Just (fun, is_infix, arg_pats) if e is a function LHS
 852 --
 853 -- The whole LHS is parsed as a single expression.
 854 -- Any infix operators on the LHS will parse left-associatively
 855 -- E.g.         f !x y !z
 856 --      will parse (rather strangely) as
 857 --              (f ! x y) ! z
 858 --      It's up to isFunLhs to sort out the mess
 859 --
 860 -- a .!. !b
 861
 862 isFunLhs e = go e []
 863  where
 864    go (L loc (HsVar f)) es
 865         | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
 866    go (L _ (HsApp f e)) es       = go f (e:es)
 867    go (L _ (HsPar e))   es@(_:_) = go e es
 868
 869         -- For infix function defns, there should be only one infix *function*
 870         -- (though there may be infix *datacons* involved too).  So we don't
 871         -- need fixity info to figure out which function is being defined.
 872         --      a `K1` b `op` c `K2` d
 873         -- must parse as
 874         --      (a `K1` b) `op` (c `K2` d)
 875         -- The renamer checks later that the precedences would yield such a parse.
 876         --
 877         -- There is a complication to deal with bang patterns.
 878         --
 879         -- ToDo: what about this?
 880         --              x + 1 `op` y = ...
 881
 882    go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
 883         | Just (e',es') <- splitBang e
 884         = do { bang_on <- extension bangPatEnabled
 885              ; if bang_on then go e' (es' ++ es)
 886                else return (Just (L loc' op, True, (l:r:es))) }
 887                 -- No bangs; behave just like the next case
 888         | not (isRdrDataCon op)         -- We have found the function!
 889         = return (Just (L loc' op, True, (l:r:es)))
 890         | otherwise                     -- Infix data con; keep going
 891         = do { mb_l <- go l es
 892              ; case mb_l of
 893                  Just (op', True, j : k : es')
 894                     -> return (Just (op', True, j : op_app : es'))
 895                     where
 896                       op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
 897                  _ -> return Nothing }
 898    go _ _ = return Nothing
 899
 900 ---------------------------------------------------------------------------
 901 -- Miscellaneous utilities
 902
 903 checkPrecP :: Located Int -> P Int
 904 checkPrecP (L l i)
 905  | 0 <= i && i <= maxPrecedence = return i
 906  | otherwise                    = parseError l "Precedence out of range"
 907
 908 mkRecConstrOrUpdate
 909         :: LHsExpr RdrName
 910         -> SrcSpan
 911         -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
 912         -> P (HsExpr RdrName)
 913
 914 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
 915   = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
 916 mkRecConstrOrUpdate exp loc (fs,dd)
 917   | null fs   = parseError loc "Empty record update"
 918   | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
 919
 920 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
 921 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
 922 mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
 923
 924 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
 925 -- The Maybe is becuase the user can omit the activation spec (and usually does)
 926 mkInlineSpec Nothing    True  = alwaysInlineSpec        -- INLINE
 927 mkInlineSpec Nothing    False = neverInlineSpec         -- NOINLINE
 928 mkInlineSpec (Just act) inl   = Inline act inl
 929
 930
 931 -----------------------------------------------------------------------------
 932 -- utilities for foreign declarations
 933
 934 -- supported calling conventions
 935 --
 936 data CallConv = CCall  CCallConv        -- ccall or stdcall
 937               | DNCall                  -- .NET
 938
 939 -- construct a foreign import declaration
 940 --
 941 mkImport :: CallConv
 942          -> Safety
 943          -> (Located FastString, Located RdrName, LHsType RdrName)
 944          -> P (HsDecl RdrName)
 945 mkImport (CCall  cconv) safety (entity, v, ty) = do
 946   importSpec <- parseCImport entity cconv safety v
 947   return (ForD (ForeignImport v ty importSpec))
 948 mkImport (DNCall      ) _      (entity, v, ty) = do
 949   spec <- parseDImport entity
 950   return $ ForD (ForeignImport v ty (DNImport spec))
 951
 952 -- parse the entity string of a foreign import declaration for the `ccall' or
 953 -- `stdcall' calling convention'
 954 --
 955 parseCImport :: Located FastString
 956              -> CCallConv
 957              -> Safety
 958              -> Located RdrName
 959              -> P ForeignImport
 960 parseCImport (L loc entity) cconv safety v
 961   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
 962   | entity == fsLit "dynamic" =
 963     return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
 964   | entity == fsLit "wrapper" =
 965     return $ CImport cconv safety nilFS nilFS CWrapper
 966   | otherwise                  = parse0 (unpackFS entity)
 967     where
 968       -- using the static keyword?
 969       parse0 (' ':                    rest) = parse0 rest
 970       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
 971       parse0                          rest  = parse1 rest
 972       -- check for header file name
 973       parse1     ""               = parse4 ""    nilFS        False nilFS
 974       parse1     (' ':rest)       = parse1 rest
 975       parse1 str@('&':_   )       = parse2 str   nilFS
 976       parse1 str@('[':_   )       = parse3 str   nilFS        False
 977       parse1 str
 978         | ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
 979         | otherwise               = parse4 str   nilFS        False nilFS
 980         where
 981           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
 982       -- check for address operator (indicating a label import)
 983       parse2     ""         header = parse4 ""   header False nilFS
 984       parse2     (' ':rest) header = parse2 rest header
 985       parse2     ('&':rest) header = parse3 rest header True
 986       parse2 str@('[':_   ) header = parse3 str  header False
 987       parse2 str            header = parse4 str  header False nilFS
 988       -- check for library object name
 989       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
 990       parse3 ('[':rest) header isLbl =
 991         case break (== ']') rest of
 992           (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
 993           _                         -> parseError loc "Missing ']' in entity"
 994       parse3 str        header isLbl = parse4 str  header isLbl nilFS
 995       -- check for name of C function
 996       parse4 ""         header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
 997       parse4 (' ':rest) header isLbl lib = parse4 rest                 header isLbl lib
 998       parse4 str        header isLbl lib
 999         | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
1000         | otherwise                      = parseError loc "Malformed entity string"
1001         where
1002           (first, rest) = break (== ' ') str
1003       --
1004       build cid header False lib = return $
1005         CImport cconv safety header lib (CFunction (StaticTarget cid))
1006       build cid header True  lib = return $
1007         CImport cconv safety header lib (CLabel                  cid )
1008
1009 --
1010 -- Unravel a dotnet spec string.
1011 --
1012 parseDImport :: Located FastString -> P DNCallSpec
1013 parseDImport (L loc entity) = parse0 comps
1014  where
1015   comps = words (unpackFS entity)
1016
1017   parse0 [] = d'oh
1018   parse0 (x : xs)
1019     | x == "static" = parse1 True xs
1020     | otherwise     = parse1 False (x:xs)
1021
1022   parse1 _ [] = d'oh
1023   parse1 isStatic (x:xs)
1024     | x == "method" = parse2 isStatic DNMethod xs
1025     | x == "field"  = parse2 isStatic DNField xs
1026     | x == "ctor"   = parse2 isStatic DNConstructor xs
1027   parse1 isStatic xs = parse2 isStatic DNMethod xs
1028
1029   parse2 _ _ [] = d'oh
1030   parse2 isStatic kind (('[':x):xs) =
1031      case x of
1032         [] -> d'oh
1033         vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
1034         _ -> d'oh
1035   parse2 isStatic kind xs = parse3 isStatic kind "" xs
1036
1037   parse3 isStatic kind assem [x] =
1038     return (DNCallSpec isStatic kind assem x
1039                           -- these will be filled in once known.
1040                         (error "FFI-dotnet-args")
1041                         (error "FFI-dotnet-result"))
1042   parse3 _ _ _ _ = d'oh
1043
1044   d'oh = parseError loc "Malformed entity string"
1045
1046 -- construct a foreign export declaration
1047 --
1048 mkExport :: CallConv
1049          -> (Located FastString, Located RdrName, LHsType RdrName)
1050          -> P (HsDecl RdrName)
1051 mkExport (CCall  cconv) (L _ entity, v, ty) = return $
1052   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1053   where
1054     entity' | nullFS entity = mkExtName (unLoc v)
1055             | otherwise     = entity
1056 mkExport DNCall (L _ _, v, _) =
1057   parseError (getLoc v){-TODO: not quite right-}
1058         "Foreign export is not yet supported for .NET"
1059
1060 -- Supplying the ext_name in a foreign decl is optional; if it
1061 -- isn't there, the Haskell name is assumed. Note that no transformation
1062 -- of the Haskell name is then performed, so if you foreign export (++),
1063 -- it's external name will be "++". Too bad; it's important because we don't
1064 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1065 --
1066 mkExtName :: RdrName -> CLabelString
1067 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1068 \end{code}
1069
1070
1071 -----------------------------------------------------------------------------
1072 -- Misc utils
1073
1074 \begin{code}
1075 parseError :: SrcSpan -> String -> P a
1076 parseError span s = parseErrorSDoc span (text s)
1077
1078 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1079 parseErrorSDoc span s = failSpanMsgP span s
1080 \end{code}