[project @ 2002-09-19 12:31:08 by simonmar]
[ghc-hetmet.git] / ghc / compiler / parser / ParseUtil.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1999
3 %
4 \section[ParseUtil]{Parser Utilities}
5
6 \begin{code}
7 module ParseUtil (
8           parseError          -- String -> Pa
9         , mkPrefixCon, mkRecCon
10
11         , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
12         , groupBindings
13         
14         , mkIfaceExports      -- :: [RdrNameTyClDecl] -> [RdrExportItem]
15
16         , CallConv(..)
17         , mkImport            -- CallConv -> Safety 
18                               -- -> (FastString, RdrName, RdrNameHsType)
19                               -- -> SrcLoc 
20                               -- -> P RdrNameHsDecl
21         , mkExport            -- CallConv
22                               -- -> (FastString, RdrName, RdrNameHsType)
23                               -- -> SrcLoc 
24                               -- -> P RdrNameHsDecl
25         , mkExtName           -- RdrName -> CLabelString
26                               
27         , checkPrec           -- String -> P String
28         , checkContext        -- HsType -> P HsContext
29         , checkPred           -- HsType -> P HsPred
30         , checkTyVars         -- [HsTyVar] -> P [HsType]
31         , checkTyClHdr        -- HsType -> (name,[tyvar])
32         , checkInstType       -- HsType -> P HsType
33         , checkPattern        -- HsExp -> P HsPat
34         , checkPatterns       -- SrcLoc -> [HsExp] -> P [HsPat]
35         , checkDo             -- [Stmt] -> P [Stmt]
36         , checkValDef         -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
37         , checkValSig         -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
38  ) where
39
40 #include "HsVersions.h"
41
42 import List             ( isSuffixOf )
43
44 import Lex
45 import HscTypes         ( RdrAvailInfo, GenAvailInfo(..) )
46 import HsSyn            -- Lots of it
47 import TysWiredIn       ( unitTyCon )
48 import ForeignCall      ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
49                           DNCallSpec(..))
50 import SrcLoc
51 import RdrHsSyn
52 import RdrName
53 import OccName          ( dataName, varName, isDataOcc, isTcOcc, occNameUserString )
54 import CStrings         ( CLabelString )
55 import FastString
56 import Outputable
57
58 -----------------------------------------------------------------------------
59 -- Misc utils
60
61 parseError :: String -> P a
62 parseError s = 
63   getSrcLocP `thenP` \ loc ->
64   failMsgP (hcat [ppr loc, text ": ", text s])
65
66
67 -----------------------------------------------------------------------------
68 -- mkPrefixCon
69
70 -- When parsing data declarations, we sometimes inadvertently parse
71 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
72 -- This function splits up the type application, adds any pending
73 -- arguments, and converts the type constructor back into a data constructor.
74
75 mkPrefixCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
76
77 mkPrefixCon ty tys
78  = split ty tys
79  where
80    split (HsAppTy t u)  ts = split t (unbangedType u : ts)
81    split (HsTyVar tc)   ts = tyConToDataCon tc  `thenP` \ data_con ->
82                              returnP (data_con, PrefixCon ts)
83    split _               _ = parseError "Illegal data/newtype declaration"
84
85 mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
86 mkRecCon con fields
87   = tyConToDataCon con  `thenP` \ data_con ->
88     returnP (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
89
90 tyConToDataCon :: RdrName -> P RdrName
91 tyConToDataCon tc
92   | isTcOcc (rdrNameOcc tc)
93   = returnP (setRdrNameSpace tc dataName)
94   | otherwise
95   = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
96
97 ----------------------------------------------------------------------------
98 -- Various Syntactic Checks
99
100 checkInstType :: RdrNameHsType -> P RdrNameHsType
101 checkInstType t 
102   = case t of
103         HsForAllTy tvs ctxt ty ->
104                 checkDictTy ty [] `thenP` \ dict_ty ->
105                 returnP (HsForAllTy tvs ctxt dict_ty)
106
107         HsParTy ty -> checkInstType ty
108
109         ty ->   checkDictTy ty [] `thenP` \ dict_ty->
110                 returnP (HsForAllTy Nothing [] dict_ty)
111
112 checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar]
113 checkTyVars tvs = mapP chk tvs
114                 where
115                   chk (HsKindSig (HsTyVar tv) k) = returnP (IfaceTyVar tv k)
116                   chk (HsTyVar tv)               = returnP (UserTyVar tv)
117                   chk other                      = parseError "Type found where type variable expected"
118
119 checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar])
120 -- The header of a type or class decl should look like
121 --      (C a, D b) => T a b
122 -- or   T a b
123 -- or   a + b
124 -- etc
125 checkTyClHdr ty
126   = go ty []
127   where
128     go (HsTyVar tc)    acc 
129         | not (isRdrTyVar tc) = checkTyVars acc         `thenP` \ tvs ->
130                                 returnP (tc, tvs)
131     go (HsOpTy t1 (HsTyOp tc) t2) acc  
132                               = checkTyVars (t1:t2:acc) `thenP` \ tvs ->
133                                 returnP (tc, tvs)
134     go (HsParTy ty)    acc    = go ty acc
135     go (HsAppTy t1 t2) acc    = go t1 (t2:acc)
136     go other           acc    = parseError "Malformed LHS to type of class declaration"
137
138 checkContext :: RdrNameHsType -> P RdrNameContext
139 checkContext (HsTupleTy _ ts)   -- (Eq a, Ord b) shows up as a tuple type
140   = mapP checkPred ts
141
142 checkContext (HsParTy ty)       -- to be sure HsParTy doesn't get into the way
143   = checkContext ty
144
145 checkContext (HsTyVar t)        -- Empty context shows up as a unit type ()
146   | t == getRdrName unitTyCon = returnP []
147
148 checkContext t 
149   = checkPred t `thenP` \p ->
150     returnP [p]
151
152 checkPred :: RdrNameHsType -> P (HsPred RdrName)
153 -- Watch out.. in ...deriving( Show )... we use checkPred on 
154 -- the list of partially applied predicates in the deriving,
155 -- so there can be zero args.
156 checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty)
157 checkPred ty
158   = go ty []
159   where
160     go (HsTyVar t) args   | not (isRdrTyVar t) 
161                           = returnP (HsClassP t args)
162     go (HsAppTy l r) args = go l (r:args)
163     go (HsParTy t)   args = go t args
164     go _             _    = parseError "Illegal class assertion"
165
166 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
167 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) 
168         = returnP (mkHsDictTy t args)
169 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
170 checkDictTy (HsParTy t)   args = checkDictTy t args
171 checkDictTy _ _ = parseError "Malformed context in instance header"
172
173
174 ---------------------------------------------------------------------------
175 -- Checking statements in a do-expression
176 --      We parse   do { e1 ; e2 ; }
177 --      as [ExprStmt e1, ExprStmt e2]
178 -- checkDo (a) checks that the last thing is an ExprStmt
179 --         (b) transforms it to a ResultStmt
180
181 checkDo []               = parseError "Empty 'do' construct"
182 checkDo [ExprStmt e _ l] = returnP [ResultStmt e l]
183 checkDo [s]              = parseError "The last statement in a 'do' construct must be an expression"
184 checkDo (s:ss)           = checkDo ss   `thenP` \ ss' ->
185                            returnP (s:ss')
186
187 ---------------------------------------------------------------------------
188 -- Checking Patterns.
189
190 -- We parse patterns as expressions and check for valid patterns below,
191 -- converting the expression into a pattern at the same time.
192
193 checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
194 checkPattern loc e = setSrcLocP loc (checkPat e [])
195
196 checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
197 checkPatterns loc es = mapP (checkPattern loc) es
198
199 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
200 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c (PrefixCon args))
201 checkPat (HsApp f x) args = 
202         checkPat x [] `thenP` \x ->
203         checkPat f (x:args)
204 checkPat e [] = case e of
205         EWildPat           -> returnP (WildPat placeHolderType)
206         HsVar x            -> returnP (VarPat x)
207         HsLit l            -> returnP (LitPat l)
208         HsOverLit l        -> returnP (NPatIn l Nothing)
209         ELazyPat e         -> checkPat e [] `thenP` (returnP . LazyPat)
210         EAsPat n e         -> checkPat e [] `thenP` (returnP . AsPat n)
211         ExprWithTySig e t  -> checkPat e [] `thenP` \e ->
212                               -- Pattern signatures are parsed as sigtypes,
213                               -- but they aren't explicit forall points.  Hence
214                               -- we have to remove the implicit forall here.
215                               let t' = case t of 
216                                           HsForAllTy Nothing [] ty -> ty
217                                           other -> other
218                               in
219                               returnP (SigPatIn e t')
220
221         -- Translate out NegApps of literals in patterns. We negate
222         -- the Integer here, and add back the call to 'negate' when
223         -- we typecheck the pattern.
224         -- NB. Negative *primitive* literals are already handled by
225         --     RdrHsSyn.mkHsNegApp
226         NegApp (HsOverLit lit) neg -> returnP (NPatIn lit (Just neg))
227
228         OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _)) 
229                            | plus == plus_RDR
230                            -> returnP (mkNPlusKPat n lit)
231                            where
232                               plus_RDR = mkUnqual varName FSLIT("+")    -- Hack
233
234         OpApp l op fix r   -> checkPat l [] `thenP` \l ->
235                               checkPat r [] `thenP` \r ->
236                               case op of
237                                  HsVar c | isDataOcc (rdrNameOcc c)
238                                         -> returnP (ConPatIn c (InfixCon l r))
239                                  _ -> patFail
240
241         HsPar e            -> checkPat e [] `thenP` (returnP . ParPat)
242         ExplicitList _ es  -> mapP (\e -> checkPat e []) es `thenP` \ps ->
243                               returnP (ListPat ps placeHolderType)
244         ExplicitPArr _ es  -> mapP (\e -> checkPat e []) es `thenP` \ps ->
245                               returnP (PArrPat ps placeHolderType)
246
247         ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
248                               returnP (TuplePat ps b)
249
250         RecordCon c fs     -> mapP checkPatField fs `thenP` \fs ->
251                               returnP (ConPatIn c (RecCon fs))
252 -- Generics 
253         HsType ty          -> returnP (TypePat ty) 
254         _                  -> patFail
255
256 checkPat _ _ = patFail
257
258 checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat)
259 checkPatField (n,e) = checkPat e [] `thenP` \p ->
260                       returnP (n,p)
261
262 patFail = parseError "Parse error in pattern"
263
264
265 ---------------------------------------------------------------------------
266 -- Check Equation Syntax
267
268 checkValDef 
269         :: RdrNameHsExpr
270         -> Maybe RdrNameHsType
271         -> RdrNameGRHSs
272         -> SrcLoc
273         -> P RdrBinding
274
275 checkValDef lhs opt_sig grhss loc
276  = case isFunLhs lhs [] of
277            Just (f,inf,es) -> 
278                 checkPatterns loc es `thenP` \ps ->
279                 returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
280
281            Nothing ->
282                 checkPattern loc lhs `thenP` \lhs ->
283                 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
284
285 checkValSig
286         :: RdrNameHsExpr
287         -> RdrNameHsType
288         -> SrcLoc
289         -> P RdrBinding
290 checkValSig (HsVar v) ty loc | isUnqual v = returnP (RdrSig (Sig v ty loc))
291 checkValSig other     ty loc = parseError "Type signature given for an expression"
292
293
294 -- A variable binding is parsed as an RdrNameFunMonoBind.
295 -- See comments with HsBinds.MonoBinds
296
297 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
298 isFunLhs (OpApp l (HsVar op) fix r) es  | not (isRdrDataCon op)
299                                 = Just (op, True, (l:r:es))
300                                         | otherwise
301                                 = case isFunLhs l es of
302                                     Just (op', True, j : k : es') ->
303                                       Just (op', True, j : OpApp k (HsVar op) fix r : es')
304                                     _ -> Nothing
305 isFunLhs (HsVar f) es | not (isRdrDataCon f)
306                                 = Just (f,False,es)
307 isFunLhs (HsApp f e) es         = isFunLhs f (e:es)
308 isFunLhs (HsPar e)   es@(_:_)   = isFunLhs e es
309 isFunLhs _ _                    = Nothing
310
311 ---------------------------------------------------------------------------
312 -- Miscellaneous utilities
313
314 checkPrec :: Integer -> P ()
315 checkPrec i | 0 <= i && i <= 9 = returnP ()
316             | otherwise        = parseError "Precedence out of range"
317
318 mkRecConstrOrUpdate 
319         :: RdrNameHsExpr 
320         -> RdrNameHsRecordBinds
321         -> P RdrNameHsExpr
322
323 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
324   = returnP (RecordCon c fs)
325 mkRecConstrOrUpdate exp fs@(_:_) 
326   = returnP (RecordUpd exp fs)
327 mkRecConstrOrUpdate _ _
328   = parseError "Empty record update"
329
330 -----------------------------------------------------------------------------
331 -- utilities for foreign declarations
332
333 -- supported calling conventions
334 --
335 data CallConv = CCall  CCallConv        -- ccall or stdcall
336               | DNCall                  -- .NET
337
338 -- construct a foreign import declaration
339 --
340 mkImport :: CallConv 
341          -> Safety 
342          -> (FastString, RdrName, RdrNameHsType) 
343          -> SrcLoc 
344          -> P RdrNameHsDecl
345 mkImport (CCall  cconv) safety (entity, v, ty) loc =
346   parseCImport entity cconv safety v                     `thenP` \importSpec ->
347   returnP $ ForD (ForeignImport v ty importSpec                     False loc)
348 mkImport (DNCall      ) _      (entity, v, ty) loc =
349   returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc)
350
351 -- parse the entity string of a foreign import declaration for the `ccall' or
352 -- `stdcall' calling convention'
353 --
354 parseCImport :: FastString 
355              -> CCallConv 
356              -> Safety 
357              -> RdrName 
358              -> P ForeignImport
359 parseCImport entity cconv safety v
360   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
361   | entity == FSLIT ("dynamic") = 
362     returnP $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
363   | entity == FSLIT ("wrapper") =
364     returnP $ CImport cconv safety nilFS nilFS CWrapper
365   | otherwise                  = parse0 (unpackFS entity)
366     where
367       -- using the static keyword?
368       parse0 (' ':                    rest) = parse0 rest
369       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
370       parse0                          rest  = parse1 rest
371       -- check for header file name
372       parse1     ""               = parse4 ""    nilFS        False nilFS
373       parse1     (' ':rest)       = parse1 rest
374       parse1 str@('&':_   )       = parse2 str   nilFS
375       parse1 str@('[':_   )       = parse3 str   nilFS        False
376       parse1 str
377         | ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
378         | otherwise               = parse4 str   nilFS        False nilFS
379         where
380           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
381       -- check for address operator (indicating a label import)
382       parse2     ""         header = parse4 ""   header False nilFS
383       parse2     (' ':rest) header = parse2 rest header
384       parse2     ('&':rest) header = parse3 rest header True
385       parse2 str@('[':_   ) header = parse3 str  header False
386       parse2 str            header = parse4 str  header False nilFS
387       -- check for library object name
388       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
389       parse3 ('[':rest) header isLbl = 
390         case break (== ']') rest of 
391           (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
392           _                         -> parseError "Missing ']' in entity"
393       parse3 str        header isLbl = parse4 str  header isLbl nilFS
394       -- check for name of C function
395       parse4 ""         header isLbl lib = build (mkExtName v) header isLbl lib
396       parse4 (' ':rest) header isLbl lib = parse4 rest         header isLbl lib
397       parse4 str        header isLbl lib
398         | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
399         | otherwise                      = parseError "Malformed entity string"
400         where
401           (first, rest) = break (== ' ') str
402       --
403       build cid header False lib = returnP $
404         CImport cconv safety header lib (CFunction (StaticTarget cid))
405       build cid header True  lib = returnP $
406         CImport cconv safety header lib (CLabel                  cid )
407
408 -- construct a foreign export declaration
409 --
410 mkExport :: CallConv
411          -> (FastString, RdrName, RdrNameHsType) 
412          -> SrcLoc 
413          -> P RdrNameHsDecl
414 mkExport (CCall  cconv) (entity, v, ty) loc = returnP $ 
415   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
416   where
417     entity' | nullFastString entity = mkExtName v
418             | otherwise             = entity
419 mkExport DNCall (entity, v, ty) loc =
420   parseError "Foreign export is not yet supported for .NET"
421
422 -- Supplying the ext_name in a foreign decl is optional; if it
423 -- isn't there, the Haskell name is assumed. Note that no transformation
424 -- of the Haskell name is then performed, so if you foreign export (++),
425 -- it's external name will be "++". Too bad; it's important because we don't
426 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
427 -- (This is why we use occNameUserString.)
428 --
429 mkExtName :: RdrName -> CLabelString
430 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
431
432 -----------------------------------------------------------------------------
433 -- group function bindings into equation groups
434
435 -- we assume the bindings are coming in reverse order, so we take the srcloc
436 -- from the *last* binding in the group as the srcloc for the whole group.
437
438 groupBindings :: [RdrBinding] -> RdrBinding
439 groupBindings binds = group Nothing binds
440   where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
441         group (Just bind) [] = RdrValBinding bind
442         group Nothing [] = RdrNullBind
443
444                 -- don't group together FunMonoBinds if they have
445                 -- no arguments.  This is necessary now that variable bindings
446                 -- with no arguments are now treated as FunMonoBinds rather
447                 -- than pattern bindings (tests/rename/should_fail/rnfail002).
448         group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
449                     (RdrValBinding (FunMonoBind f' _ 
450                                         [mtch@(Match (_:_) _ _)] loc)
451                         : binds)
452             | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
453
454         group (Just so_far) binds
455             = RdrValBinding so_far `RdrAndBindings` group Nothing binds
456         group Nothing (bind:binds)
457             = case bind of
458                 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
459                 other -> bind `RdrAndBindings` group Nothing binds
460
461 -- ---------------------------------------------------------------------------
462 -- Make the export list for an interface
463
464 mkIfaceExports :: [RdrNameTyClDecl] -> [RdrAvailInfo]
465 mkIfaceExports decls = map getExport decls
466   where getExport d = case d of
467                         TyData{}    -> tc_export
468                         ClassDecl{} -> tc_export
469                         _other      -> var_export
470           where 
471                 tc_export  = AvailTC (rdrNameOcc (tcdName d)) 
472                                 (map (rdrNameOcc.fst) (tyClDeclNames d))
473                 var_export = Avail (rdrNameOcc (tcdName d))
474 \end{code}