RdrHsSyn.lhs 36.7 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, mkClassDecl,
12
	mkHsNegApp, mkHsIntegral, mkHsFractional,
13
	mkHsDo, mkHsSplice,
14
        mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,	
15
	mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
16

17 18
	cvBindGroup,
	cvBindsAndSigs,
19
	cvTopDecls,
20
	findSplice, mkGroup,
21 22

	-- Stuff to do with Foreign declarations
23 24
	CallConv(..),
	mkImport,            -- CallConv -> Safety 
25 26
			      -- -> (FastString, RdrName, RdrNameHsType)
			      -- -> P RdrNameHsDecl
27
	mkExport,            -- CallConv
28 29
			      -- -> (FastString, RdrName, RdrNameHsType)
			      -- -> P RdrNameHsDecl
30
	mkExtName,           -- RdrName -> CLabelString
31
	mkGadtDecl,          -- Located RdrName -> LHsType RdrName -> ConDecl RdrName
32 33 34
			      
	-- Bunch of functions in the parser monad for 
	-- checking and constructing values
35 36 37
	checkPrecP, 	      -- Int -> P Int
	checkContext,	      -- HsType -> P HsContext
	checkPred,	      -- HsType -> P HsPred
38
	checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
39 40
	checkTyVars,          -- [LHsType RdrName] -> P ()
	checkSynHdr,	      -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
41
	checkKindSigs,	      -- [LTyClDecl RdrName] -> P ()
42 43 44 45 46 47 48 49
	checkInstType,	      -- HsType -> P HsType
	checkPattern,	      -- HsExp -> P HsPat
	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
	parseError,	      -- String -> Pa
50 51
    ) where

52
#include "HsVersions.h"
53

54
import HsSyn		-- Lots of it
55
import RdrName		( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, 
56
			  isRdrDataCon, isUnqual, getRdrName, isQual,
57
			  setRdrNameSpace )
58
import BasicTypes	( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
59
import Lexer		( P, failSpanMsgP, extension, bangPatEnabled )
60
import TysWiredIn	( unitTyCon ) 
61
import ForeignCall	( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
62
			  DNCallSpec(..), DNKind(..), CLabelString )
63
import OccName  	( srcDataName, varName, isDataOcc, isTcOcc, 
64
			  occNameString )
65
import SrcLoc
66
import OrdList		( OrdList, fromOL )
67
import Bag		( Bag, emptyBag, snocBag, consBag, foldrBag )
68 69 70
import Outputable
import FastString
import Panic
71 72

import List		( isSuffixOf, nubBy )
73
import Monad		( unless )
74 75
\end{code}

76 77 78 79

%************************************************************************
%*									*
\subsection{A few functions over HsSyn at RdrName}
80
%*                                                                    *
81 82
%************************************************************************

83
extractHsTyRdrNames finds the free variables of a HsType
84 85 86
It's used when making the for-alls explicit.

\begin{code}
87 88
extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
89

90
extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
91 92
-- This one takes the context and tau-part of a 
-- sigma type and returns their free type variables
93 94 95
extractHsRhoRdrTyVars ctxt ty 
 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])

96
extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
97 98 99 100

extract_pred (HsClassP cls tys) acc	= foldr extract_lty acc tys
extract_pred (HsIParam n ty) acc	= extract_lty ty acc

101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124
extract_lty (L loc ty) acc 
  = case ty of
      HsTyVar tv 	        -> extract_tv loc tv acc
      HsBangTy _ ty            	-> extract_lty ty acc
      HsAppTy ty1 ty2          	-> extract_lty ty1 (extract_lty ty2 acc)
      HsListTy ty              	-> extract_lty ty acc
      HsPArrTy ty              	-> extract_lty ty acc
      HsTupleTy _ tys          	-> foldr extract_lty acc tys
      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
      HsNumTy num              	-> acc
      HsSpliceTy _             	-> acc	-- Type splices mention no type variables
      HsKindSig ty k	        -> extract_lty ty acc
      HsForAllTy exp [] cx ty   -> extract_lctxt cx (extract_lty ty acc)
      HsForAllTy exp tvs cx ty  -> acc ++ (filter ((`notElem` locals) . unLoc) $
					   extract_lctxt cx (extract_lty ty []))
				where
				   locals = hsLTyVarNames tvs

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

126
extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
127 128 129
-- Get the type variables out of the type patterns in a bunch of
-- possibly-generic bindings in a class declaration
extractGenericPatTyVars binds
130
  = nubBy eqLocated (foldrBag get [] binds)
131
  where
132 133
    get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
    get other	 	   			          acc = acc
134

135 136
    get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
    get_m other			       		   acc = acc
137 138
\end{code}

139 140 141 142 143 144 145

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

146
mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
147 148 149
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
150 151
file (which would be equally good).

152
Similarly for mkConDecl, mkClassOpSig and default-method names.
153 154

	*** See "THE NAMING STORY" in HsDecls ****
155
  
156
\begin{code}
157
mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats
158
  = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
159
		tcdFDs = fds,  
160
		tcdSigs = sigs,
161 162
		tcdMeths = mbinds,
		tcdATs   = ats
163
		}
164

165
mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
166
  = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
167
	     tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons, 
168
	     tcdKindSig = ksig, tcdDerivs = maybe_deriv }
169
\end{code}
170

171
\begin{code}
172 173
mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
-- RdrName If the type checker sees (negate 3#) it will barf, because negate
174 175
-- can't take an unboxed arg.  But that is exactly what it will see when
-- we write "-3#".  So we have to do the negation right now!
176 177 178 179
mkHsNegApp (L loc e) = f e
  where f (HsLit (HsIntPrim i))    = HsLit (HsIntPrim (-i))    
	f (HsLit (HsFloatPrim i))  = HsLit (HsFloatPrim (-i))  
	f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i)) 
180
	f expr	    		   = NegApp (L loc e) noSyntaxExpr
181
\end{code}
182

183
%************************************************************************
184
%*									*
185
\subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
186 187 188 189 190 191 192 193
%*									*
%************************************************************************

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


194
\begin{code}
195
--  | Groups together bindings for a single function
196 197
cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
cvTopDecls decls = go (fromOL decls)
198
  where
199 200 201 202 203 204
    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

205 206
-- Declaration list may only contain value bindings and signatures
--
207
cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
208
cvBindGroup binding
209 210 211
  = case cvBindsAndSigs binding of
      (mbs, sigs, []) ->                 -- list of type decls *always* empty
        ValBindsIn mbs sigs
212

213
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
214
  -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName])
215
-- Input decls contain just value bindings and signatures
216
-- and in case of class or instance declarations also
217
-- associated type declarations
218
cvBindsAndSigs  fb = go (fromOL fb)
219
  where
220 221 222 223 224 225 226 227
    go [] 		   = (emptyBag, [], [])
    go (L l (SigD s) : ds) = (bs, L l s : ss, ts)
			    where (bs, ss, ts) = go ds
    go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts)
			    where (b', ds')    = getMonoBind (L l b) ds
				  (bs, ss, ts) = go ds'
    go (L l (TyClD t): ds) = (bs, ss, L l t : ts)
			    where (bs, ss, ts) = go ds
228 229 230 231

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

232 233
getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
  -> (LHsBind RdrName, [LHsDecl RdrName])
234
-- Suppose 	(b',ds') = getMonoBind b ds
235
-- 	ds is a list of parsed bindings
236 237 238 239 240 241 242 243
--	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.
--
-- No AndMonoBinds or EmptyMonoBinds here; just single equations

244 245 246 247
getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1, 
				   fun_matches = MatchGroup mtchs1 _ })) binds
  | has_args mtchs1
  = go is_infix1 mtchs1 loc1 binds
248
  where
249 250 251 252 253 254 255
    go is_infix mtchs loc 
       (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
			        fun_matches = MatchGroup mtchs2 _ })) : binds)
	| f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs) 
		        (combineSrcSpans loc loc2) binds
    go is_infix mtchs loc binds
	= (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), binds)
256
	-- Reverse the final matches, to get it back in the right order
257

258 259
getMonoBind bind binds = (bind, binds)

260 261
has_args ((L _ (Match args _ _)) : _) = not (null args)
	-- Don't group together FunBinds if they have
262
	-- no arguments.  This is necessary now that variable bindings
263
	-- with no arguments are now treated as FunBinds rather
264
	-- than pattern bindings (tests/rename/should_fail/rnfail002).
265 266
\end{code}

267
\begin{code}
268
findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
269
findSplice ds = addl emptyRdrGroup ds
270

271
mkGroup :: [LHsDecl a] -> HsGroup a
272
mkGroup ds = addImpDecls emptyRdrGroup ds
273

274
addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
275
-- The decls are imported, and should not have a splice
276
addImpDecls group decls = case addl group decls of
277 278 279
				(group', Nothing) -> group'
				other		  -> panic "addImpDecls"

280
addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
281 282 283
	-- This stuff reverses the declarations (again) but it doesn't matter

-- Base cases
284
addl gp []	     = (gp, Nothing)
285 286 287 288 289 290 291
addl gp (L l d : ds) = add gp l d ds


add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
  -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))

add gp l (SpliceD e) ds = (gp, Just (e, ds))
292 293

-- Class declarations: pull out the fixity signatures to the top
294 295 296 297 298 299
add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
	| isClassDecl d = 	
		let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
		addl (gp { hs_tyclds = L l d : ts, hs_fixds  = fsigs ++ fs }) ds
	| otherwise =
		addl (gp { hs_tyclds = L l d : ts }) ds
300 301

-- Signatures: fixity sigs go a different place than all others
302 303 304 305
add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
  = addl (gp {hs_fixds = L l f : ts}) ds
add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
  = addl (gp {hs_valds = add_sig (L l d) ts}) ds
306 307

-- Value declarations: use add_bind
308 309
add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
  = addl (gp { hs_valds = add_bind (L l d) ts }) ds
310 311

-- The rest are routine
312 313 314 315 316 317 318 319 320 321 322
add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
  = addl (gp { hs_instds = L l d : ts }) ds
add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
  = addl (gp { hs_defds = L l d : ts }) ds
add gp@(HsGroup {hs_fords  = ts})  l (ForD d) ds
  = addl (gp { hs_fords = L l d : ts }) ds
add gp@(HsGroup {hs_depds  = ts})  l (DeprecD d) ds
  = addl (gp { hs_depds = L l d : ts }) ds
add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
  = addl (gp { hs_ruleds = L l d : ts }) ds

323 324
add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
add_sig  s (ValBindsIn bs sigs) = ValBindsIn bs	              (s:sigs) 
325
\end{code}
326 327 328 329 330 331 332 333 334

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


\begin{code}
335 336 337 338 339 340 341 342
-----------------------------------------------------------------------------
-- mkPrefixCon

-- 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.

343 344
mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
  -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
345 346 347
mkPrefixCon ty tys
 = split ty tys
 where
348
   split (L _ (HsAppTy t u)) ts = split t (u : ts)
349 350 351 352 353 354 355 356 357 358 359 360
   split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
				     return (data_con, PrefixCon ts)
   split (L l _) _ 		= parseError l "parse error in data/newtype declaration"

mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
  -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
mkRecCon (L loc con) fields
  = do data_con <- tyConToDataCon loc con
       return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])

tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
tyConToDataCon loc tc
361
  | isTcOcc (rdrNameOcc tc)
362
  = return (L loc (setRdrNameSpace tc srcDataName))
363
  | otherwise
364
  = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
365 366 367 368

----------------------------------------------------------------------------
-- Various Syntactic Checks

369 370
checkInstType :: LHsType RdrName -> P (LHsType RdrName)
checkInstType (L l t)
371
  = case t of
372 373 374
	HsForAllTy exp tvs ctxt ty -> do
		dict_ty <- checkDictTy ty
	      	return (L l (HsForAllTy exp tvs ctxt dict_ty))
375 376 377

        HsParTy ty -> checkInstType ty

378 379
	ty ->   do dict_ty <- checkDictTy (L l ty)
	      	   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
380

381
-- Check whether the given list of type parameters are all type variables
382
-- (possibly with a kind signature).  If the second argument is `False',
383
-- only type variables are allowed and we raise an error on encountering a
384 385
-- non-variable; otherwise, we allow non-variable arguments and return the
-- entire list of parameters.
386
--
387 388
checkTyVars :: [LHsType RdrName] -> P ()
checkTyVars tparms = mapM_ chk tparms
389
  where
390
	-- Check that the name space is correct!
391
    chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
392
	| isRdrTyVar tv    = return ()
393
    chk (L l (HsTyVar tv))
394 395
        | isRdrTyVar tv    = return ()
    chk (L l other)        =
396
	  parseError l "Type found where type variable expected"
397

398 399
-- Check whether the type arguments in a type synonym head are simply
-- variables.  If not, we have a type equation of a type function and return
400 401
-- all patterns.  If yes, we return 'Nothing' as the third component to
-- indicate a vanilla type synonym.
402 403
--
checkSynHdr :: LHsType RdrName 
404
	    -> Bool                             -- is type instance?
405 406
	    -> P (Located RdrName,		-- head symbol
	          [LHsTyVarBndr RdrName],	-- parameters
407 408
		  [LHsType RdrName])	        -- type patterns
checkSynHdr ty isTyInst = 
409
  do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
410 411
     ; unless isTyInst $ checkTyVars tparms
     ; return (tc, tvs, tparms) }
412 413 414 415


-- Well-formedness check and decomposition of type and class heads.
--
416
checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
417 418 419
  -> P (LHsContext RdrName,	     -- the type context
        Located RdrName,	     -- the head symbol (type or class name)
	[LHsTyVarBndr RdrName],	     -- free variables of the non-context part
420
	[LHsType RdrName])           -- parameters of head symbol
421 422 423 424 425
-- The header of a type or class decl should look like
--	(C a, D b) => T a b
-- or	T a b
-- or	a + b
-- etc
426 427 428 429 430 431
-- With associated types, we can also have non-variable parameters; ie,
--      T Int [a]
-- The unaltered parameter list is returned in the fourth component of the
-- result.  Eg, for
--      T Int [a]
-- we return
432
--      ('()', 'T', ['a'], ['Int', '[a]'])
433
checkTyClHdr (L l cxt) ty
434
  = do (tc, tvs, parms) <- gol ty []
435
       mapM_ chk_pred cxt
436
       return (L l cxt, tc, tvs, parms)
437
  where
438 439 440
    gol (L l ty) acc = go l ty acc

    go l (HsTyVar tc)    acc 
441 442 443 444 445 446
	| not (isRdrTyVar tc)   = do
				    tvs <- extractTyVars acc
				    return (L l tc, tvs, acc)
    go l (HsOpTy t1 tc t2) acc  = do
				    tvs <- extractTyVars (t1:t2:acc)
				    return (tc, tvs, acc)
447 448
    go l (HsParTy ty)    acc    = gol ty acc
    go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
449 450
    go l other	         acc    = 
      parseError l "Malformed head of type or class declaration"
451

452 453 454
	-- The predicates in a type or class decl must all
	-- be HsClassPs.  They need not all be type variables,
	-- even in Haskell 98.  E.g. class (Monad m, Monad (t m)) => MonadT t m
455 456 457
    chk_pred (L l (HsClassP _ args)) = return ()
    chk_pred (L l _)
       = parseError l "Malformed context in type or class declaration"
458

459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504
-- Extract the type variables of a list of type parameters.
--
-- * Type arguments can be complex type terms (needed for associated type
--   declarations).
--
extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
extractTyVars tvs = collects [] tvs
  where
        -- Collect all variables (1st arg serves as an accumulator)
    collect tvs (L l (HsForAllTy _ _ _ _)) =
      parseError l "Forall type not allowed as type parameter"
    collect tvs (L l (HsTyVar tv))
      | isRdrTyVar tv			   = return $ L l (UserTyVar tv) : tvs
      | otherwise			   = return tvs
    collect tvs (L l (HsBangTy _ _      )) =
      parseError l "Bang-style type annotations not allowed as type parameter"
    collect tvs (L l (HsAppTy t1 t2     )) = do
					       tvs' <- collect tvs t2
					       collect tvs' t1
    collect tvs (L l (HsFunTy t1 t2     )) = do
					       tvs' <- collect tvs t2
					       collect tvs' t1
    collect tvs (L l (HsListTy t        )) = collect tvs t
    collect tvs (L l (HsPArrTy t        )) = collect tvs t
    collect tvs (L l (HsTupleTy _ ts    )) = collects tvs ts
    collect tvs (L l (HsOpTy t1 _ t2    )) = do
					       tvs' <- collect tvs t2
					       collect tvs' t1
    collect tvs (L l (HsParTy t         )) = collect tvs t
    collect tvs (L l (HsNumTy t         )) = return tvs
    collect tvs (L l (HsPredTy t        )) = 
      parseError l "Predicate not allowed as type parameter"
    collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
	| isRdrTyVar tv                    = 
	  return $ L l (KindedTyVar tv k) : tvs
	| otherwise                        =
	  parseError l "Kind signature only allowed for type variables"
    collect tvs (L l (HsSpliceTy t      )) = 
      parseError l "Splice not allowed as type parameter"

        -- Collect all variables of a list of types
    collects tvs []     = return tvs
    collects tvs (t:ts) = do
			    tvs' <- collects tvs ts
			    collect tvs' t

505 506 507 508 509 510 511 512 513 514 515
-- Check that associated type declarations of a class are all kind signatures.
--
checkKindSigs :: [LTyClDecl RdrName] -> P ()
checkKindSigs = mapM_ check
  where
    check (L l tydecl) 
      | isKindSigDecl tydecl
        || isSynDecl tydecl  = return ()
      | otherwise	     = 
	parseError l "Type declaration in a class must be a kind signature or synonym default"

516 517 518 519 520 521 522 523 524 525
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)
526

527 528
  check (HsTyVar t)	-- Empty context shows up as a unit type ()
    | t == getRdrName unitTyCon = return (L l [])
529

530 531 532
  check t 
    = do p <- checkPred (L l t)
         return (L l [p])
533 534


535
checkPred :: LHsType RdrName -> P (LHsPred RdrName)
536 537 538
-- Watch out.. in ...deriving( Show )... we use checkPred on 
-- the list of partially applied predicates in the deriving,
-- so there can be zero args.
539
checkPred (L spn (HsPredTy (HsIParam n ty)))
540 541 542
  = return (L spn (HsIParam n ty))
checkPred (L spn ty)
  = check spn ty []
543
  where
544
    checkl (L l ty) args = check l ty args
545

546 547 548 549 550 551
    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
    check loc _                        _    = parseError loc  "malformed class assertion"
552

553 554 555
checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
checkDictTy (L spn ty) = check ty []
  where
556
  check (HsTyVar t) args | not (isRdrTyVar t) 
557
  	= return (L spn (HsPredTy (HsClassP t args)))
558 559 560
  check (HsAppTy l r) args = check (unLoc l) (r:args)
  check (HsParTy t)   args = check (unLoc t) args
  check _ _ = parseError spn "Malformed context in instance header"
561 562 563 564 565 566

---------------------------------------------------------------------------
-- 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
567
--	   (b) returns it separately
568 569 570 571 572
-- same comments apply for mdo as well

checkDo	 = checkDoMDo "a " "'do'"
checkMDo = checkDoMDo "an " "'mdo'"

573
checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
574 575 576 577
checkDoMDo pre nm loc []   = parseError loc ("Empty " ++ nm ++ " construct")
checkDoMDo pre nm loc ss   = do 
  check ss
  where 
578
	check  [L l (ExprStmt e _ _)] = return ([], e)
579 580 581
	check  [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
					 " construct must be an expression")
	check (s:ss) = do
582 583
	  (ss',e') <-  check ss
	  return ((s:ss'),e')
584

585
-- -------------------------------------------------------------------------
586 587 588 589 590
-- Checking Patterns.

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

591 592 593 594 595 596 597 598 599 600 601 602
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
603 604 605 606 607 608 609 610 611 612
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) []
  = do { p <- checkAPat loc e; return (L loc p) }
613 614 615 616 617 618 619 620 621 622 623 624 625 626
checkPat loc pat _some_args
  = patFail loc

checkAPat loc e = case e of
   EWildPat	       -> return (WildPat placeHolderType)
   HsVar x | isQual x  -> parseError loc ("Qualified variable in pattern: "
					 ++ showRdrName x)
   	   | otherwise -> return (VarPat x)
   HsLit l 	       -> return (LitPat l)

   -- Overloaded numeric patterns (e.g. f 0 x = x)
   -- Negation is recorded separately, so that the literal is zero or +ve
   -- NB. Negative *primitive* literals are already handled by
   --     RdrHsSyn.mkHsNegApp
627
   HsOverLit pos_lit            -> return (mkNPat pos_lit Nothing)
628
   NegApp (L _ (HsOverLit pos_lit)) _ 
629
			-> return (mkNPat pos_lit (Just noSyntaxExpr))
630
   
631 632 633 634 635 636
   SectionR (L _ (HsVar bang)) e 	-- (! x)
 	| bang == bang_RDR 
	-> do { bang_on <- extension bangPatEnabled
	      ; if bang_on then checkLPat e >>= (return . BangPat)
		else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
637 638
   ELazyPat e	      -> checkLPat e >>= (return . LazyPat)
   EAsPat n e	      -> checkLPat e >>= (return . AsPat n)
639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668
   ExprWithTySig e t  -> checkLPat e >>= \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
   			 in
   			 return (SigPatIn e t')
   
   -- n+k patterns
   OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ 
	(L _ (HsOverLit lit@(HsIntegral _ _)))
   		      | plus == plus_RDR
   		      -> return (mkNPlusKPat (L nloc n) lit)
   
   OpApp l op fix r   -> checkLPat l >>= \l ->
   			 checkLPat r >>= \r ->
   			 case op of
   			    L cl (HsVar c) | isDataOcc (rdrNameOcc c)
   				   -> return (ConPatIn (L cl c) (InfixCon l r))
   			    _ -> patFail loc
   
   HsPar e		   -> checkLPat e >>= (return . ParPat)
   ExplicitList _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
   			 return (ListPat ps placeHolderType)
   ExplicitPArr _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
   			 return (PArrPat ps placeHolderType)
   
   ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
669
   			 return (TuplePat ps b placeHolderType)
670
   
671
   RecordCon c _ fs   -> mapM checkPatField fs >>= \fs ->
672
			 return (ConPatIn c (RecCon fs))
673
-- Generics 
674 675
   HsType ty          -> return (TypePat ty) 
   _                  -> patFail loc
676

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
677 678 679 680
plus_RDR, bang_RDR :: RdrName
plus_RDR = mkUnqual varName FSLIT("+")	-- Hack
bang_RDR = mkUnqual varName FSLIT("!")	-- Hack

681 682 683 684
checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
checkPatField (n,e) = do
  p <- checkLPat e
  return (n,p)
685

686
patFail loc = parseError loc "Parse error in pattern"
687 688 689 690 691


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

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
692 693 694 695 696
checkValDef :: LHsExpr RdrName
	    -> Maybe (LHsType RdrName)
	    -> Located (GRHSs RdrName)
	    -> P (HsBind RdrName)

697 698 699 700
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
701 702 703 704 705 706 707 708 709 710 711 712 713 714
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 }

checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
  | isQual (unLoc fun)
  = parseError (getLoc fun) ("Qualified name in function definition: "  ++ 
			     showRdrName (unLoc fun))
  | otherwise
  = do	ps <- checkPatterns pats
	let match_span = combineSrcSpans lhs_loc rhs_span
715
	return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
716 717
	-- 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
718

719 720 721 722 723 724
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,
	      fun_co_fn = idCoercion, bind_fvs = placeHolderNames }

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
725 726 727
checkPatBind lhs (L _ grhss)
  = do	{ lhs <- checkPattern lhs
	; return (PatBind lhs grhss placeHolderType placeHolderNames) }
728 729

checkValSig
730 731 732
	:: LHsExpr RdrName
	-> LHsType RdrName
	-> P (Sig RdrName)
733 734 735
checkValSig (L l (HsVar v)) ty 
  | isUnqual v && not (isDataOcc (rdrNameOcc v))
  = return (TypeSig (L l v) ty)
736
checkValSig (L l other)     ty
737
  = parseError l "Invalid type signature"
738

739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754
mkGadtDecl :: Located RdrName
           -> LHsType RdrName -- assuming HsType
           -> ConDecl RdrName
mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
mkGadtDecl name ty				  = mk_gadt_con name [] (noLoc []) ty

mk_gadt_con name qvars cxt ty
  = ConDecl { con_name     = name
	    , con_explicit = Implicit
	    , con_qvars    = qvars
	    , con_cxt      = cxt
	    , con_details  = PrefixCon []
	    , con_res      = ResTyGADT ty }
  -- NB: we put the whole constr type into the ResTyGADT for now; 
  -- the renamer will unravel it once it has sorted out
  -- operator fixities
755

756 757
-- A variable binding is parsed as a FunBind.

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773

	-- The parser left-associates, so there should 
	-- not be any OpApps inside the e's
splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
-- Splits (f ! g a b) into (f, [(! g), a, g])
splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
  | 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)
splitBang other = Nothing

isFunLhs :: LHsExpr RdrName 
	 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
-- Just (fun, is_infix, arg_pats) if e is a function LHS
774
isFunLhs e = go e []
775
 where
776
   go (L loc (HsVar f)) es 
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
777
	| not (isRdrDataCon f)	 = return (Just (L loc f, False, es))
778 779
   go (L _ (HsApp f e)) es 	 = go f (e:es)
   go (L _ (HsPar e))   es@(_:_) = go e es
780 781 782 783 784 785 786 787 788 789 790 791 792 793

	-- 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
794 795 796 797 798 799
   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
800
	| not (isRdrDataCon op) 	-- We have found the function!
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
801
	= return (Just (L loc' op, True, (l:r:es)))
802
	| otherwise			-- Infix data con; keep going
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
803 804 805 806 807 808 809 810
	= 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
811 812 813 814

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

815 816 817 818
checkPrecP :: Located Int -> P Int
checkPrecP (L l i)
 | 0 <= i && i <= maxPrecedence = return i
 | otherwise     	        = parseError l "Precedence out of range"
819 820

mkRecConstrOrUpdate 
821 822 823 824 825 826
	:: LHsExpr RdrName 
	-> SrcSpan
	-> HsRecordBinds RdrName
	-> P (HsExpr RdrName)

mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
827
  = return (RecordCon (L l c) noPostTcExpr fs)
828
mkRecConstrOrUpdate exp loc fs@(_:_)
829
  = return (RecordUpd exp fs placeHolderType placeHolderType)
830 831
mkRecConstrOrUpdate _ loc []
  = parseError loc "Empty record update"
832

833 834 835 836 837 838 839
mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
-- The Maybe is becuase the user can omit the activation spec (and usually does)
mkInlineSpec Nothing 	True  = alwaysInlineSpec	-- INLINE
mkInlineSpec Nothing 	False = neverInlineSpec		-- NOINLINE
mkInlineSpec (Just act) inl   = Inline act inl


840 841 842 843 844 845 846 847 848 849 850 851
-----------------------------------------------------------------------------
-- utilities for foreign declarations

-- supported calling conventions
--
data CallConv = CCall  CCallConv	-- ccall or stdcall
	      | DNCall			-- .NET

-- construct a foreign import declaration
--
mkImport :: CallConv 
	 -> Safety 
852 853 854 855
	 -> (Located FastString, Located RdrName, LHsType RdrName) 
	 -> P (HsDecl RdrName)
mkImport (CCall  cconv) safety (entity, v, ty) = do
  importSpec <- parseCImport entity cconv safety v
Simon Marlow's avatar
Simon Marlow committed
856
  return (ForD (ForeignImport v ty importSpec))
857 858
mkImport (DNCall      ) _      (entity, v, ty) = do
  spec <- parseDImport entity
Simon Marlow's avatar
Simon Marlow committed
859
  return $ ForD (ForeignImport v ty (DNImport spec))
860 861 862 863

-- parse the entity string of a foreign import declaration for the `ccall' or
-- `stdcall' calling convention'
--
864
parseCImport :: Located FastString
865 866
	     -> CCallConv 
	     -> Safety 
867
	     -> Located RdrName
868
	     -> P ForeignImport
869
parseCImport (L loc entity) cconv safety v
870 871
  -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
  | entity == FSLIT ("dynamic") = 
872
    return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
873
  | entity == FSLIT ("wrapper") =
874
    return $ CImport cconv safety nilFS nilFS CWrapper
875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901
  | otherwise		       = parse0 (unpackFS entity)
    where
      -- using the static keyword?
      parse0 (' ':                    rest) = parse0 rest
      parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
      parse0                          rest  = parse1 rest
      -- check for header file name
      parse1     ""               = parse4 ""    nilFS        False nilFS
      parse1     (' ':rest)       = parse1 rest
      parse1 str@('&':_   )       = parse2 str   nilFS
      parse1 str@('[':_   )       = parse3 str   nilFS        False
      parse1 str
	| ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
        | otherwise               = parse4 str   nilFS        False nilFS
        where
	  (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
      -- check for address operator (indicating a label import)
      parse2     ""         header = parse4 ""   header False nilFS
      parse2     (' ':rest) header = parse2 rest header
      parse2     ('&':rest) header = parse3 rest header True
      parse2 str@('[':_   ) header = parse3 str	 header False
      parse2 str	    header = parse4 str	 header False nilFS
      -- check for library object name
      parse3 (' ':rest) header isLbl = parse3 rest header isLbl
      parse3 ('[':rest) header isLbl = 
        case break (== ']') rest of 
	  (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
902
	  _			    -> parseError loc "Missing ']' in entity"
903 904
      parse3 str	header isLbl = parse4 str  header isLbl nilFS
      -- check for name of C function
905 906
      parse4 ""         header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
      parse4 (' ':rest) header isLbl lib = parse4 rest         	       header isLbl lib
907 908
      parse4 str	header isLbl lib
        | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
909
	| otherwise			 = parseError loc "Malformed entity string"
910 911 912
        where
	  (first, rest) = break (== ' ') str
      --
913
      build cid header False lib = return $
914
        CImport cconv safety header lib (CFunction (StaticTarget cid))
915
      build cid header True  lib = return $
916 917
        CImport cconv safety header lib (CLabel                  cid )

sof's avatar
sof committed
918 919 920
--
-- Unravel a dotnet spec string.
--
921 922
parseDImport :: Located FastString -> P DNCallSpec
parseDImport (L loc entity) = parse0 comps
sof's avatar
sof committed
923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945
 where
  comps = words (unpackFS entity)

  parse0 [] = d'oh
  parse0 (x : xs) 
    | x == "static" = parse1 True xs
    | otherwise     = parse1 False (x:xs)

  parse1 _ [] = d'oh
  parse1 isStatic (x:xs)
    | x == "method" = parse2 isStatic DNMethod xs
    | x == "field"  = parse2 isStatic DNField xs
    | x == "ctor"   = parse2 isStatic DNConstructor xs
  parse1 isStatic xs = parse2 isStatic DNMethod xs

  parse2 _ _ [] = d'oh
  parse2 isStatic kind (('[':x):xs) =
     case x of
	[] -> d'oh
	vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
  parse2 isStatic kind xs = parse3 isStatic kind "" xs

  parse3 isStatic kind assem [x] = 
946
    return (DNCallSpec isStatic kind assem x 
sof's avatar
sof committed
947 948 949 950 951
    			  -- these will be filled in once known.
                        (error "FFI-dotnet-args")
                        (error "FFI-dotnet-result"))
  parse3 _ _ _ _ = d'oh

952
  d'oh = parseError loc "Malformed entity string"
sof's avatar
sof committed
953
  
954 955 956
-- construct a foreign export declaration
--
mkExport :: CallConv
957 958 959
         -> (Located FastString, Located RdrName, LHsType RdrName) 
	 -> P (HsDecl RdrName)
mkExport (CCall  cconv) (L loc entity, v, ty) = return $ 
Simon Marlow's avatar
Simon Marlow committed
960
  ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
961
  where
962 963
    entity' | nullFS entity = mkExtName (unLoc v)
	    | otherwise     = entity
964 965 966
mkExport DNCall (L loc entity, v, ty) =
  parseError (getLoc v){-TODO: not quite right-}
	"Foreign export is not yet supported for .NET"
967 968 969 970 971 972 973 974

-- Supplying the ext_name in a foreign decl is optional; if it
-- isn't there, the Haskell name is assumed. Note that no transformation
-- of the Haskell name is then performed, so if you foreign export (++),
-- it's external name will be "++". Too bad; it's important because we don't
-- want z-encoding (e.g. names with z's in them shouldn't be doubled)
--
mkExtName :: RdrName -> CLabelString
975
mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
976
\end{code}
977 978 979 980 981 982


-----------------------------------------------------------------------------
-- Misc utils

\begin{code}
983 984 985
showRdrName :: RdrName -> String
showRdrName r = showSDoc (ppr r)

986 987
parseError :: SrcSpan -> String -> P a
parseError span s = failSpanMsgP span s
988
\end{code}