RdrHsSyn.lhs 40.4 KB
Newer Older
1
%
2
% (c) The University of Glasgow, 1996-2003
3

4
Functions over HsSyn specialised to RdrName.
5 6 7

\begin{code}
module RdrHsSyn (
8 9
	extractHsTyRdrTyVars, 
	extractHsRhoRdrTyVars, extractGenericPatTyVars,
10
 
11
	mkHsOpApp, 
12
	mkHsIntegral, mkHsFractional, mkHsIsString,
13
	mkHsDo, mkHsSplice, mkTopSpliceDecl,
14
        mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
15
        splitCon, mkInlinePragma,	
16
	mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
17

18
	cvBindGroup,
19
        cvBindsAndSigs,
20
	cvTopDecls,
21
        placeHolderPunRhs,
22 23

	-- Stuff to do with Foreign declarations
24
	mkImport,
25
        parseCImport,
26
	mkExport,
27
	mkExtName,           -- RdrName -> CLabelString
28
	mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
29 30
	mkSimpleConDecl, 
	mkDeprecatedGadtRecordDecl,
31

32 33
	-- Bunch of functions in the parser monad for 
	-- checking and constructing values
34 35 36
	checkPrecP, 	      -- Int -> P Int
	checkContext,	      -- HsType -> P HsContext
	checkPred,	      -- HsType -> P HsPred
37
	checkTyVars,          -- [LHsType RdrName] -> P ()
38
	checkKindSigs,	      -- [LTyClDecl RdrName] -> P ()
39 40
	checkInstType,	      -- HsType -> P HsType
	checkPattern,	      -- HsExp -> P HsPat
41
	bang_RDR,
42 43 44 45 46
	checkPatterns,	      -- SrcLoc -> [HsExp] -> P [HsPat]
	checkDo,	      -- [Stmt] -> P [Stmt]
	checkMDo,	      -- [Stmt] -> P [Stmt]
	checkValDef,	      -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
	checkValSig,	      -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
Ian Lynagh's avatar
Ian Lynagh committed
47
	checkDoAndIfThenElse,
48 49
	parseError,	    
	parseErrorSDoc,	    
50 51
    ) where

52
import HsSyn		-- Lots of it
53 54
import Class            ( FunDep )
import TypeRep          ( Kind )
55
import RdrName		( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
56
			  isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
57
import BasicTypes	( maxPrecedence, Activation(..), RuleMatchInfo,
58
                          InlinePragma(..), InlineSpec(..) )
59
import Lexer
60
import TysWiredIn	( unitTyCon ) 
61
import ForeignCall
62
import OccName  	( srcDataName, varName, isDataOcc, isTcOcc, 
63
			  occNameString )
64
import PrelNames	( forall_tv_RDR )
65
import DynFlags
66
import SrcLoc
67
import OrdList		( OrdList, fromOL )
68
import Bag		( Bag, emptyBag, consBag, foldrBag )
69 70
import Outputable
import FastString
71
import Maybes
72

73
import Control.Applicative ((<$>))       
74
import Control.Monad
75 76
import Text.ParserCombinators.ReadP as ReadP
import Data.List        ( nubBy )
Ian Lynagh's avatar
Ian Lynagh committed
77
import Data.Char
78 79

#include "HsVersions.h"
80 81
\end{code}

82 83 84 85

%************************************************************************
%*									*
\subsection{A few functions over HsSyn at RdrName}
86
%*                                                                    *
87 88
%************************************************************************

89
extractHsTyRdrNames finds the free variables of a HsType
90 91 92
It's used when making the for-alls explicit.

\begin{code}
93 94
extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
95

96 97 98
extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])

99
extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
100 101
-- This one takes the context and tau-part of a 
-- sigma type and returns their free type variables
102 103 104
extractHsRhoRdrTyVars ctxt ty 
 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])

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 = extract_ltys tys acc
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 114 115
extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
extract_ltys tys acc = foldr extract_lty acc tys

116
extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
117 118 119 120
extract_lty (L loc ty) acc 
  = case ty of
      HsTyVar tv 	        -> extract_tv loc tv acc
      HsBangTy _ ty            	-> extract_lty ty acc
121
      HsRecTy flds            	-> foldr (extract_lty . cd_fld_type) acc flds
122 123 124
      HsAppTy ty1 ty2          	-> extract_lty ty1 (extract_lty ty2 acc)
      HsListTy ty              	-> extract_lty ty acc
      HsPArrTy ty              	-> extract_lty ty acc
125
      HsTupleTy _ tys          	-> extract_ltys tys acc
126 127 128 129
      HsFunTy ty1 ty2          	-> extract_lty ty1 (extract_lty ty2 acc)
      HsPredTy p		-> extract_pred p acc
      HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
      HsParTy ty               	-> extract_lty ty acc
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
130 131
      HsNumTy {}                -> acc
      HsCoreTy {}               -> acc  -- The type is closed
132
      HsQuasiQuoteTy {}	        -> acc  -- Quasi quotes mention no type variables
133
      HsSpliceTy {}           	-> acc	-- Type splices mention no type variables
134 135 136
      HsKindSig ty _            -> extract_lty ty acc
      HsForAllTy _ [] cx ty     -> extract_lctxt cx (extract_lty ty acc)
      HsForAllTy _ tvs cx ty    -> acc ++ (filter ((`notElem` locals) . unLoc) $
137 138 139
					   extract_lctxt cx (extract_lty ty []))
				where
				   locals = hsLTyVarNames tvs
140
      HsDocTy ty _              -> extract_lty ty acc
141 142 143 144

extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
		      | otherwise     = acc
145

146
extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
147 148 149
-- Get the type variables out of the type patterns in a bunch of
-- possibly-generic bindings in a class declaration
extractGenericPatTyVars binds
150
  = nubBy eqLocated (foldrBag get [] binds)
151
  where
152
    get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
153
    get _                                                 acc = acc
154

155
    get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
156
    get_m _                                        acc = acc
157 158
\end{code}

159 160 161 162 163 164 165

%************************************************************************
%*									*
\subsection{Construction functions for Rdr stuff}
%*                                                                    *
%************************************************************************

166
mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
167 168 169
by deriving them from the name of the class.  We fill in the names for the
tycon and datacon corresponding to the class, by deriving them from the
name of the class itself.  This saves recording the names in the interface
170 171
file (which would be equally good).

172
Similarly for mkConDecl, mkClassOpSig and default-method names.
173 174

	*** See "THE NAMING STORY" in HsDecls ****
175
  
176
\begin{code}
177
mkClassDecl :: SrcSpan
178
            -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
179 180 181 182
            -> Located [Located (FunDep RdrName)]
            -> Located (OrdList (LHsDecl RdrName))
	    -> P (LTyClDecl RdrName)

183
mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
184
  = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
185
       ; let cxt = fromMaybe (noLoc []) mcxt
186 187 188 189 190 191 192 193 194 195
       ; (cls, tparams) <- checkTyClHdr tycl_hdr
       ; tyvars <- checkTyVars tparams      -- Only type vars allowed
       ; checkKindSigs ats
       ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
		             	    tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
			     	    tcdATs   = ats, tcdDocs  = docs })) }

mkTyData :: SrcSpan
         -> NewOrData
	 -> Bool		-- True <=> data family instance
196
         -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
197
         -> Maybe Kind
198 199 200
         -> [LConDecl RdrName]
         -> Maybe [LHsType RdrName]
         -> P (LTyClDecl RdrName)
201
mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
202 203
  = do { (tc, tparams) <- checkTyClHdr tycl_hdr

204 205
       ; checkDatatypeContext mcxt
       ; let cxt = fromMaybe (noLoc []) mcxt
206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230
       ; (tyvars, typats) <- checkTParams is_family tparams
       ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
	                  	 tcdTyVars = tyvars, tcdTyPats = typats, 
                                 tcdCons = data_cons, 
	                  	 tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }

mkTySynonym :: SrcSpan 
            -> Bool	        -- True <=> type family instances
            -> LHsType RdrName  -- LHS
            -> LHsType RdrName	-- RHS
            -> P (LTyClDecl RdrName)
mkTySynonym loc is_family lhs rhs
  = do { (tc, tparams) <- checkTyClHdr lhs
       ; (tyvars, typats) <- checkTParams is_family tparams
       ; return (L loc (TySynonym tc tyvars typats rhs)) }

mkTyFamily :: SrcSpan
           -> FamilyFlavour
	   -> LHsType RdrName   -- LHS
	   -> Maybe Kind        -- Optional kind signature
           -> P (LTyClDecl RdrName)
mkTyFamily loc flavour lhs ksig
  = do { (tc, tparams) <- checkTyClHdr lhs
       ; tyvars <- checkTyVars tparams
       ; return (L loc (TyFamily flavour tc tyvars ksig)) }
231 232 233

mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
-- If the user wrote
234 235 236 237 238 239
--      [pads| ... ]   then return a QuasiQuoteD
--	$(e)           then return a SpliceD
-- but if she wrote, say,
--      f x            then behave as if she'd written $(f x)
--		       ie a SpliceD
mkTopSpliceDecl (L _ (HsQuasiQuoteE qq))            = QuasiQuoteD qq
240 241
mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr       Explicit)
mkTopSpliceDecl other_expr                          = SpliceD (SpliceDecl other_expr Implicit)
242
\end{code}
243

244
%************************************************************************
245
%*									*
246
\subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
247 248 249 250 251 252 253 254
%*									*
%************************************************************************

Function definitions are restructured here. Each is assumed to be recursive
initially, and non recursive definitions are discovered by the dependency
analyser.


255
\begin{code}
256
--  | Groups together bindings for a single function
257 258
cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
cvTopDecls decls = go (fromOL decls)
259
  where
260 261 262 263 264 265
    go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
    go [] 		    = []
    go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'
			    where (L l' b', ds') = getMonoBind (L l b) ds
    go (d : ds)   	    = d : go ds

266
-- Declaration list may only contain value bindings and signatures.
267
cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
268
cvBindGroup binding
269
  = case cvBindsAndSigs binding of
270 271
      (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
      	    	  	         ValBindsIn mbs sigs
272

273
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
274
  -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl])
275
-- Input decls contain just value bindings and signatures
276
-- and in case of class or instance declarations also
277
-- associated type declarations. They might also contain Haddock comments.
278
cvBindsAndSigs  fb = go (fromOL fb)
279
  where
280
    go [] 		   = (emptyBag, [], [], [])
281
    go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
282
			   where (bs, ss, ts, docs) = go ds
283
    go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
284 285
			   where (b', ds')    = getMonoBind (L l b) ds
				 (bs, ss, ts, docs) = go ds'
286
    go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
287 288 289 290
			   where (bs, ss, ts, docs) = go ds
    go (L l (DocD d) : ds) =  (bs, ss, ts, (L l d) : docs)
			   where (bs, ss, ts, docs) = go ds
    go (L _ d : _)        = pprPanic "cvBindsAndSigs" (ppr d)
291 292 293 294

-----------------------------------------------------------------------------
-- Group function bindings into equation groups

295 296
getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
  -> (LHsBind RdrName, [LHsDecl RdrName])
297
-- Suppose 	(b',ds') = getMonoBind b ds
298
-- 	ds is a list of parsed bindings
299 300 301 302 303 304
--	b is a MonoBinds that has just been read off the front

-- Then b' is the result of grouping more equations from ds that
-- belong with b into a single MonoBinds, and ds' is the depleted
-- list of parsed bindings.
--
305 306 307
-- All Haddock comments between equations inside the group are 
-- discarded.
--
308 309
-- No AndMonoBinds or EmptyMonoBinds here; just single equations

310 311
getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
                               fun_matches = MatchGroup mtchs1 _ })) binds
312
  | has_args mtchs1
313
  = go is_infix1 mtchs1 loc1 binds []
314
  where
315 316
    go is_infix mtchs loc 
       (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
317
			        fun_matches = MatchGroup mtchs2 _ })) : binds) _
318
	| f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs) 
319 320 321 322 323 324
		        (combineSrcSpans loc loc2) binds []
    go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls 
	= let doc_decls' = doc_decl : doc_decls  
          in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
    go is_infix mtchs loc binds doc_decls
	= (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
325
	-- Reverse the final matches, to get it back in the right order
326
        -- Do the same thing with the trailing doc comments
327

328 329
getMonoBind bind binds = (bind, binds)

330
has_args :: [LMatch RdrName] -> Bool
331
has_args [] 	    	     	      = panic "RdrHsSyn:has_args"
332 333
has_args ((L _ (Match args _ _)) : _) = not (null args)
	-- Don't group together FunBinds if they have
334
	-- no arguments.  This is necessary now that variable bindings
335
	-- with no arguments are now treated as FunBinds rather
336
	-- than pattern bindings (tests/rename/should_fail/rnfail002).
337 338 339 340 341 342 343 344 345 346
\end{code}

%************************************************************************
%*									*
\subsection[PrefixToHS-utils]{Utilities for conversion}
%*									*
%************************************************************************


\begin{code}
347
-----------------------------------------------------------------------------
348
-- splitCon
349 350 351 352 353 354

-- When parsing data declarations, we sometimes inadvertently parse
-- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
-- This function splits up the type application, adds any pending
-- arguments, and converts the type constructor back into a data constructor.

355 356 357 358 359 360 361 362
splitCon :: LHsType RdrName
      -> P (Located RdrName, HsConDeclDetails RdrName)
-- This gets given a "type" that should look like
--      C Int Bool
-- or   C { x::Int, y::Bool }
-- and returns the pieces
splitCon ty
 = split ty []
363
 where
364
   split (L _ (HsAppTy t u)) ts = split t (u : ts)
365
   split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
366
 				     return (data_con, mk_rest ts)
367
   split (L l _) _ 	        = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty)
368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403

   mk_rest [L _ (HsRecTy flds)] = RecCon flds
   mk_rest ts                   = PrefixCon ts

mkDeprecatedGadtRecordDecl :: SrcSpan 
		     	   -> Located RdrName
		     	   -> [ConDeclField RdrName]
			   -> LHsType RdrName
		     	   ->  P (LConDecl  RdrName)
-- This one uses the deprecated syntax
--    C { x,y ::Int } :: T a b
-- We give it a RecCon details right away
mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
  = do { data_con <- tyConToDataCon con_loc con
       ; return (L loc (ConDecl { con_old_rec  = True
                                , con_name     = data_con
	    	 		, con_explicit = Implicit
	    	 		, con_qvars    = []
	    	 		, con_cxt      = noLoc []
	    	 		, con_details  = RecCon flds
	    	 		, con_res      = ResTyGADT res_ty
            	 		, con_doc      = Nothing })) }

mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
		-> LHsContext RdrName -> HsConDeclDetails RdrName
		-> ConDecl RdrName

mkSimpleConDecl name qvars cxt details
  = ConDecl { con_old_rec  = False
            , con_name     = name
	    , con_explicit = Explicit
	    , con_qvars    = qvars
	    , con_cxt      = cxt
	    , con_details  = details
	    , con_res      = ResTyH98
            , con_doc      = Nothing }
404

405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429
mkGadtDecl :: [Located RdrName]
           -> LHsType RdrName     -- Always a HsForAllTy
           -> [ConDecl RdrName]
-- We allow C,D :: ty
-- and expand it as if it had been 
--    C :: ty; D :: ty
-- (Just like type signatures in general.)
mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
  = [mk_gadt_con name | name <- names]
  where
    (details, res_ty)		-- See Note [Sorting out the result type]
      = case tau of
    	  L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds,  res_ty)
	  _other                                    -> (PrefixCon [], tau)

    mk_gadt_con name
       = ConDecl { con_old_rec  = False
                 , con_name     = name
	    	 , con_explicit = imp
	    	 , con_qvars    = qvars
	    	 , con_cxt      = cxt
	    	 , con_details  = details
	    	 , con_res      = ResTyGADT res_ty
            	 , con_doc      = Nothing }
mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
430 431 432

tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
tyConToDataCon loc tc
433
  | isTcOcc (rdrNameOcc tc)
434
  = return (L loc (setRdrNameSpace tc srcDataName))
435
  | otherwise
436 437 438 439 440 441
  = parseErrorSDoc loc (msg $$ extra)
  where
    msg = text "Not a data constructor:" <+> quotes (ppr tc)
    extra | tc == forall_tv_RDR
	  = text "Perhaps you intended to use -XExistentialQuantification"
	  | otherwise = empty
442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459
\end{code}

Note [Sorting out the result type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In a GADT declaration which is not a record, we put the whole constr
type into the ResTyGADT for now; the renamer will unravel it once it
has sorted out operator fixities. Consider for example
     C :: a :*: b -> a :*: b -> a :+: b
Initially this type will parse as
      a :*: (b -> (a :*: (b -> (a :+: b))))

so it's hard to split up the arguments until we've done the precedence
resolution (in the renamer) On the other hand, for a record
	{ x,y :: Int } -> a :*: b
there is no doubt.  AND we need to sort records out so that
we can bring x,y into scope.  So:
   * For PrefixCon we keep all the args in the ResTyGADT
   * For RecCon we do not
460

461
\begin{code}
462 463 464
----------------------------------------------------------------------------
-- Various Syntactic Checks

465 466
checkInstType :: LHsType RdrName -> P (LHsType RdrName)
checkInstType (L l t)
467
  = case t of
468 469 470
	HsForAllTy exp tvs ctxt ty -> do
		dict_ty <- checkDictTy ty
	      	return (L l (HsForAllTy exp tvs ctxt dict_ty))
471 472 473

        HsParTy ty -> checkInstType ty

474 475
	ty ->   do dict_ty <- checkDictTy (L l ty)
	      	   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
476

477 478 479
checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
checkDictTy (L spn ty) = check ty []
  where
480 481
  check (HsTyVar tc)            args | isRdrTc tc = done tc args
  check (HsOpTy t1 (L _ tc) t2) args | isRdrTc tc = done tc (t1:t2:args)
482 483
  check (HsAppTy l r) args = check (unLoc l) (r:args)
  check (HsParTy t)   args = check (unLoc t) args
484
  check _ _ = parseErrorSDoc spn (text "Malformed instance header:" <+> ppr ty)
485

486 487
  done tc args = return (L spn (HsPredTy (HsClassP tc args)))

488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510
checkTParams :: Bool	  -- Type/data family
	     -> [LHsType RdrName]
	     -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
-- checkTParams checks the type parameters of a data/newtype declaration
-- There are two cases:
--
--  a) Vanilla data/newtype decl. In that case 
--        - the type parameters should all be type variables
--        - they may have a kind annotation
--
--  b) Family data/newtype decl.  In that case
--        - The type parameters may be arbitrary types
--        - We find the type-varaible binders by find the 
--          free type vars of those types
--        - We make them all kind-sig-free binders (UserTyVar)
--          If there are kind sigs in the type parameters, they
--          will fix the binder's kind when we kind-check the 
--          type parameters
checkTParams is_family tparams
  | not is_family        -- Vanilla case (a)
  = do { tyvars <- checkTyVars tparams
       ; return (tyvars, Nothing) }
  | otherwise		 -- Family case (b)
511
  = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams)
512 513 514
       ; return (tyvars, Just tparams) }

checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
515
-- Check whether the given list of type parameters are all type variables
516
-- (possibly with a kind signature).  If the second argument is `False',
517
-- only type variables are allowed and we raise an error on encountering a
518 519
-- non-variable; otherwise, we allow non-variable arguments and return the
-- entire list of parameters.
520
checkTyVars tparms = mapM chk tparms
521
  where
522
	-- Check that the name space is correct!
523 524 525
    chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
	| isRdrTyVar tv    = return (L l (KindedTyVar tv k))
    chk (L l (HsTyVar tv))
526
        | isRdrTyVar tv    = return (L l (UserTyVar tv placeHolderKind))
527 528 529 530
    chk t@(L l _)            =
	  parseErrorSDoc l (text "Type found:" <+> ppr t
                     $$ text "where type variable expected, in:" <+>
                        sep (map (pprParendHsType . unLoc) tparms))
531

532 533
checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
checkDatatypeContext Nothing = return ()
534
checkDatatypeContext (Just (L loc c))
535 536
    = do allowed <- extension datatypeContextsEnabled
         unless allowed $
537 538 539
             parseErrorSDoc loc
                 (text "Illegal datatype context (use -XDatatypeContexts):" <+>
                  pprHsContext c)
540

541 542 543
checkTyClHdr :: LHsType RdrName
             -> P (Located RdrName,	     -- the head symbol (type or class name)
	           [LHsType RdrName])        -- parameters of head symbol
544
-- Well-formedness check and decomposition of type and class heads.
545 546 547 548 549
-- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
-- 		Int :*: Bool   into    (:*:, [Int, Bool])
-- returning the pieces
checkTyClHdr ty
  = goL ty []
550
  where
551
    goL (L l ty) acc = go l ty acc
552

553
    go l (HsTyVar tc) acc 
554 555
	| isRdrTc tc 	     = return (L l tc, acc)
				     
556
    go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
557 558 559
	| isRdrTc tc	     = return (ltc, t1:t2:acc)
    go _ (HsParTy ty)    acc = goL ty acc
    go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
560
    go l _               _   = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty)
561

562 563 564 565 566 567
-- Check that associated type declarations of a class are all kind signatures.
--
checkKindSigs :: [LTyClDecl RdrName] -> P ()
checkKindSigs = mapM_ check
  where
    check (L l tydecl) 
568
      | isFamilyDecl tydecl
569 570
        || isSynDecl tydecl  = return ()
      | otherwise	     = 
571
	parseErrorSDoc l (text "Type declaration in a class must be a kind signature or synonym default:" $$ ppr tydecl)
572

573 574 575 576 577 578 579 580 581 582
checkContext :: LHsType RdrName -> P (LHsContext RdrName)
checkContext (L l t)
  = check t
 where
  check (HsTupleTy _ ts) 	-- (Eq a, Ord b) shows up as a tuple type
    = do ctx <- mapM checkPred ts
	 return (L l ctx)

  check (HsParTy ty)	-- to be sure HsParTy doesn't get into the way
    = check (unLoc ty)
583

584 585
  check (HsTyVar t)	-- Empty context shows up as a unit type ()
    | t == getRdrName unitTyCon = return (L l [])
586

587 588 589
  check t 
    = do p <- checkPred (L l t)
         return (L l [p])
590 591


592
checkPred :: LHsType RdrName -> P (LHsPred RdrName)
593 594 595
-- Watch out.. in ...deriving( Show )... we use checkPred on 
-- the list of partially applied predicates in the deriving,
-- so there can be zero args.
596
checkPred (L spn (HsPredTy (HsIParam n ty)))
597 598 599
  = return (L spn (HsIParam n ty))
checkPred (L spn ty)
  = check spn ty []
600
  where
601
    checkl (L l ty) args = check l ty args
602

603 604 605
    check _loc (HsPredTy pred@(HsEqualP _ _)) 
                                       args | null args
					    = return $ L spn pred
606 607 608 609 610
    check _loc (HsTyVar t)             args | not (isRdrTyVar t) 
		 		  	    = return (L spn (HsClassP t args))
    check _loc (HsAppTy l r)           args = checkl l (r:args)
    check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
    check _loc (HsParTy t)  	       args = checkl t args
611 612
    check loc _                        _    = parseErrorSDoc loc
                                (text "malformed class assertion:" <+> ppr ty)
613

614 615 616 617 618
---------------------------------------------------------------------------
-- Checking statements in a do-expression
-- 	We parse   do { e1 ; e2 ; }
-- 	as [ExprStmt e1, ExprStmt e2]
-- checkDo (a) checks that the last thing is an ExprStmt
619
--	   (b) returns it separately
620 621
-- same comments apply for mdo as well

622 623
checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)

624 625 626
checkDo	 = checkDoMDo "a " "'do'"
checkMDo = checkDoMDo "an " "'mdo'"

627
checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
628
checkDoMDo _   nm loc []   = parseErrorSDoc loc (text ("Empty " ++ nm ++ " construct"))
629
checkDoMDo pre nm _   ss   = do
630 631
  check ss
  where 
632
	check  []                     = panic "RdrHsSyn:checkDoMDo"
633
	check  [L _ (ExprStmt e _ _)] = return ([], e)
634 635 636 637
	check  [L l e] = parseErrorSDoc l
                         (text ("The last statement in " ++ pre ++ nm ++
					            " construct must be an expression:")
                       $$ ppr e)
638
	check (s:ss) = do
639 640
	  (ss',e') <-  check ss
	  return ((s:ss'),e')
641

642
-- -------------------------------------------------------------------------
643 644 645 646 647
-- Checking Patterns.

-- We parse patterns as expressions and check for valid patterns below,
-- converting the expression into a pattern at the same time.

648 649 650 651 652 653 654 655 656 657 658 659
checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
checkPattern e = checkLPat e

checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
checkPatterns es = mapM checkPattern es

checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
checkLPat e@(L l _) = checkPat l e []

checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
checkPat loc (L l (HsVar c)) args
  | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
660 661 662 663 664 665 666 667 668
checkPat loc e args 	-- OK to let this happen even if bang-patterns
			-- are not enabled, because there is no valid
			-- non-bang-pattern parse of (C ! e)
  | Just (e', args') <- splitBang e
  = do	{ args'' <- checkPatterns args'
	; checkPat loc e' (args'' ++ args) }
checkPat loc (L _ (HsApp f x)) args
  = do { x <- checkLPat x; checkPat loc f (x:args) }
checkPat loc (L _ e) []
669 670 671
  = do { pState <- getPState
       ; p <- checkAPat (dflags pState) loc e
       ; return (L loc p) }
672 673
checkPat loc e _
  = patFail loc (unLoc e)
674

675
checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
676
checkAPat dynflags loc e0 = case e0 of
677 678 679
   EWildPat -> return (WildPat placeHolderType)
   HsVar x  -> return (VarPat x)
   HsLit l  -> return (LitPat l)
680 681 682

   -- Overloaded numeric patterns (e.g. f 0 x = x)
   -- 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 689 690 691
   SectionR (L _ (HsVar bang)) e 	-- (! x)
 	| bang == bang_RDR 
	-> do { bang_on <- extension bangPatEnabled
	      ; if bang_on then checkLPat e >>= (return . BangPat)
692
		else parseErrorSDoc loc (text "Illegal bang-pattern (use -XBangPatterns):" $$ ppr e0) }
693

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
694 695
   ELazyPat e	      -> checkLPat e >>= (return . LazyPat)
   EAsPat n e	      -> checkLPat e >>= (return . AsPat n)
696 697
   -- view pattern is well-formed if the pattern is
   EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
698 699 700 701 702 703 704 705
   ExprWithTySig e t  -> do e <- checkLPat e
                            -- Pattern signatures are parsed as sigtypes,
                            -- but they aren't explicit forall points.  Hence
                            -- we have to remove the implicit forall here.
                            let t' = case t of 
                                       L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
                                       other -> other
                            return (SigPatIn e t')
706 707 708
   
   -- n+k patterns
   OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ 
709
	 (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
710
   		      | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
711 712
   		      -> return (mkNPlusKPat (L nloc n) lit)
   
713 714 715 716 717
   OpApp l op _fix r  -> do l <- checkLPat l
                            r <- checkLPat r
                            case op of
                               L cl (HsVar c) | isDataOcc (rdrNameOcc c)
                                      -> return (ConPatIn (L cl c) (InfixCon l r))
718
                               _ -> patFail loc e0
719
   
720
   HsPar e	      -> checkLPat e >>= (return . ParPat)
Ian Lynagh's avatar
Ian Lynagh committed
721
   ExplicitList _ es  -> do ps <- mapM checkLPat es
722
                            return (ListPat ps placeHolderType)
Ian Lynagh's avatar
Ian Lynagh committed
723
   ExplicitPArr _ es  -> do ps <- mapM checkLPat es
724
                            return (PArrPat ps placeHolderType)
725
   
726 727 728
   ExplicitTuple es b 
     | all tupArgPresent es  -> do ps <- mapM checkLPat [e | Present e <- es]
                                   return (TuplePat ps b placeHolderType)
729
     | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
730
   
731 732 733
   RecordCon c _ (HsRecFields fs dd)
                      -> do fs <- mapM checkPatField fs
                            return (ConPatIn c (RecCon (HsRecFields fs dd)))
734
   HsQuasiQuoteE q    -> return (QuasiQuotePat q)
735
-- Generics 
736
   HsType ty          -> return (TypePat ty) 
737
   _                  -> patFail loc e0
738

739
placeHolderPunRhs :: LHsExpr RdrName
740 741
-- The RHS of a punned record field will be filled in by the renamer
-- It's better not to make it an error, in case we want to print it when debugging
742
placeHolderPunRhs = noLoc (HsVar pun_RDR)
743 744

plus_RDR, bang_RDR, pun_RDR :: RdrName
Ian Lynagh's avatar
Ian Lynagh committed
745 746
plus_RDR = mkUnqual varName (fsLit "+")	-- Hack
bang_RDR = mkUnqual varName (fsLit "!")	-- Hack
747
pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
748

749 750 751
checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
checkPatField fld = do	{ p <- checkLPat (hsRecFieldArg fld)
			; return (fld { hsRecFieldArg = p }) }
752

753 754
patFail :: SrcSpan -> HsExpr RdrName -> P a
patFail loc e = parseErrorSDoc loc (text "Parse error in pattern:" <+> ppr e)
755 756 757 758 759


---------------------------------------------------------------------------
-- Check Equation Syntax

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
760 761 762 763 764
checkValDef :: LHsExpr RdrName
	    -> Maybe (LHsType RdrName)
	    -> Located (GRHSs RdrName)
	    -> P (HsBind RdrName)

765 766 767 768
checkValDef lhs (Just sig) grhss
   	-- x :: ty = rhs  parses as a *pattern* binding
  = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
769 770 771 772 773 774 775
checkValDef lhs opt_sig grhss
  = do	{ mb_fun <- isFunLhs lhs
	; case mb_fun of
	    Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
						fun is_infix pats opt_sig grhss
	    Nothing -> checkPatBind lhs grhss }

776 777 778 779 780 781 782
checkFunBind :: SrcSpan
             -> Located RdrName
             -> Bool
             -> [LHsExpr RdrName]
             -> Maybe (LHsType RdrName)
             -> Located (GRHSs RdrName)
             -> P (HsBind RdrName)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
783 784 785
checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
  = do	ps <- checkPatterns pats
	let match_span = combineSrcSpans lhs_loc rhs_span
786
	return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
787 788
	-- The span of the match covers the entire equation.  
	-- That isn't quite right, but it'll do for now.
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
789

790 791 792 793
makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
-- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
makeFunBind fn is_infix ms 
  = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
andy@galois.com's avatar
andy@galois.com committed
794
	      fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
795

796 797 798
checkPatBind :: LHsExpr RdrName
             -> Located (GRHSs RdrName)
             -> P (HsBind RdrName)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
799 800 801
checkPatBind lhs (L _ grhss)
  = do	{ lhs <- checkPattern lhs
	; return (PatBind lhs grhss placeHolderType placeHolderNames) }
802 803

checkValSig
804 805 806
	:: LHsExpr RdrName
	-> LHsType RdrName
	-> P (Sig RdrName)
807 808 809
checkValSig (L l (HsVar v)) ty 
  | isUnqual v && not (isDataOcc (rdrNameOcc v))
  = return (TypeSig (L l v) ty)
810 811 812 813
checkValSig lhs@(L l _) ty
  = parseErrorSDoc l ((text "Invalid type signature:" <+>
                       ppr lhs <+> text "::" <+> ppr ty)
                   $$ text hint)
814
  where
815
    hint = if foreign_RDR `looks_like` lhs
816
           then "Perhaps you meant to use -XForeignFunctionInterface?"
817 818 819
           else if generic_RDR `looks_like` lhs
                then "Perhaps you meant to use -XGenerics?"
                else "Should be of form <variable> :: <type>"
820 821 822
    -- A common error is to forget the ForeignFunctionInterface flag
    -- so check for that, and suggest.  cf Trac #3805
    -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
823 824 825
    looks_like s (L _ (HsVar v))     = v == s
    looks_like s (L _ (HsApp lhs _)) = looks_like s lhs
    looks_like s _                   = False
826 827

    foreign_RDR = mkUnqual varName (fsLit "foreign")
828
    generic_RDR = mkUnqual varName (fsLit "generic")
Ian Lynagh's avatar
Ian Lynagh committed
829 830 831 832 833 834 835 836 837 838

checkDoAndIfThenElse :: LHsExpr RdrName
                     -> Bool
                     -> LHsExpr RdrName
                     -> Bool
                     -> LHsExpr RdrName
                     -> P ()
checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
 | semiThen || semiElse
    = do pState <- getPState
839
         unless (xopt Opt_DoAndIfThenElse (dflags pState)) $ do
Ian Lynagh's avatar
Ian Lynagh committed
840 841 842 843 844 845 846 847 848 849
             parseErrorSDoc (combineLocs guardExpr elseExpr)
                            (text "Unexpected semi-colons in conditional:"
                          $$ nest 4 expr
                          $$ text "Perhaps you meant to use -XDoAndIfThenElse?")
 | otherwise            = return ()
    where pprOptSemi True  = semi
          pprOptSemi False = empty
          expr = text "if"   <+> ppr guardExpr <> pprOptSemi semiThen <+>
                 text "then" <+> ppr thenExpr  <> pprOptSemi semiElse <+>
                 text "else" <+> ppr elseExpr
850
\end{code}
851

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
852

853
\begin{code}
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
854 855 856
	-- The parser left-associates, so there should 
	-- not be any OpApps inside the e's
splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
857
-- Splits (f ! g a b) into (f, [(! g), a, b])
858
splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
859 860 861 862 863
  | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
  where
    (arg1,argns) = split_bang r_arg []
    split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
    split_bang e	   	 es = (e,es)
864
splitBang _ = Nothing
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
865 866 867

isFunLhs :: LHsExpr RdrName 
	 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
868
-- A variable binding is parsed as a FunBind.
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
869
-- Just (fun, is_infix, arg_pats) if e is a function LHS
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
870 871 872 873 874 875 876 877 878 879
--
-- The whole LHS is parsed as a single expression.  
-- Any infix operators on the LHS will parse left-associatively
-- E.g. 	f !x y !z
-- 	will parse (rather strangely) as 
--		(f ! x y) ! z
-- 	It's up to isFunLhs to sort out the mess
--
-- a .!. !b 

880
isFunLhs e = go e []
881
 where
882
   go (L loc (HsVar f)) es 
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
883
	| not (isRdrDataCon f)	 = return (Just (L loc f, False, es))
884 885
   go (L _ (HsApp f e)) es 	 = go f (e:es)
   go (L _ (HsPar e))   es@(_:_) = go e es
886 887 888 889 890 891 892 893 894 895 896 897 898 899

	-- For infix function defns, there should be only one infix *function*
	-- (though there may be infix *datacons* involved too).  So we don't
	-- need fixity info to figure out which function is being defined.
	--	a `K1` b `op` c `K2` d
	-- must parse as
	--	(a `K1` b) `op` (c `K2` d)
	-- The renamer checks later that the precedences would yield such a parse.
	-- 
	-- There is a complication to deal with bang patterns.
	--
	-- ToDo: what about this?
	--		x + 1 `op` y = ...

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
900 901 902 903 904 905
   go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
	| Just (e',es') <- splitBang e
	= do { bang_on <- extension bangPatEnabled
	     ; if bang_on then go e' (es' ++ es)
	       else return (Just (L loc' op, True, (l:r:es))) }
		-- No bangs; behave just like the next case
906
	| not (isRdrDataCon op) 	-- We have found the function!
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
907
	= return (Just (L loc' op, True, (l:r:es)))
908
	| otherwise			-- Infix data con; keep going
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
909 910 911 912 913 914 915 916
	= do { mb_l <- go l es
	     ; case mb_l of
		 Just (op', True, j : k : es')
		    -> return (Just (op', True, j : op_app : es'))
		    where
		      op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
		 _ -> return Nothing }
   go _ _ = return Nothing
917 918 919 920

---------------------------------------------------------------------------
-- Miscellaneous utilities

921 922 923
checkPrecP :: Located Int -> P Int
checkPrecP (L l i)
 | 0 <= i && i <= maxPrecedence = return i
924 925
 | otherwise
    = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
926 927

mkRecConstrOrUpdate 
928 929
	:: LHsExpr RdrName 
	-> SrcSpan
930
	-> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
931 932
	-> P (HsExpr RdrName)

933
mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
934 935
  = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
mkRecConstrOrUpdate exp loc (fs,dd)
936
  | null fs   = parseErrorSDoc loc (text "Empty record update of:" <+> ppr exp)
937 938
  | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])

939
mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
940 941
mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
942

943
mkInlinePragma :: (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma
944
-- The Maybe is because the user can omit the activation spec (and usually does)
945
mkInlinePragma (inl, match_info) mb_act
946
  = InlinePragma { inl_inline = inl
947
                 , inl_sat    = Nothing
948 949 950 951 952
                 , inl_act    = act
                 , inl_rule   = match_info }
  where
    act = case mb_act of
            Just act -> act
953 954 955 956
            Nothing  -> -- No phase specified
                        case inl of
                          NoInline -> NeverActive
                          _other   -> AlwaysActive
957

958 959 960 961 962
-----------------------------------------------------------------------------
-- utilities for foreign declarations

-- construct a foreign import declaration
--
963
mkImport :: CCallConv
964
	 -> Safety 
965 966
	 -> (Located FastString, Located RdrName, LHsType RdrName) 
	 -> P (HsDecl RdrName)
967
mkImport cconv safety (L loc entity, v, ty)
968
  | cconv == PrimCallConv                      = do
969
  let funcTarget = CFunction (StaticTarget entity Nothing)
970 971 972
      importSpec = CImport PrimCallConv safety nilFS funcTarget
  return (ForD (ForeignImport v ty importSpec))

973
  | otherwise = do
974
    case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
975
      Nothing         -> parseErrorSDoc loc (text "Malformed entity string")
976
      Just importSpec -> return (ForD (ForeignImport v ty importSpec))
977

978 979 980 981 982 983 984 985 986
-- the string "foo" is ambigous: either a header or a C identifier.  The
-- C identifier case comes first in the alternatives below, so we pick
-- that one.
parseCImport :: CCallConv -> Safety -> FastString -> String
             -> Maybe ForeignImport
parseCImport cconv safety nm str =
 listToMaybe $ map fst $ filter (null.snd) $ 
     readP_to_S parse str
 where
987 988 989
   parse = do
       skipSpaces
       r <- choice [