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         , srcParseErr           -- StringBuffer -> SrcLoc -> Message
  10         , cbot                  -- a
  11         , splitForConApp        -- RdrNameHsType -> [RdrNameBangType]
  12                                 --     -> P (RdrName, [RdrNameBangType])
  13
  14         , mkRecConstrOrUpdate   -- HsExp -> [HsFieldUpdate] -> P HsExp
  15         , groupBindings
  16
  17         , checkAs
  18         , checkHiding
  19         , checkQualified
  20
  21         , checkPrec             -- String -> P String
  22         , checkCallConv         -- FAST_STRING -> P CallConv
  23         , checkContext          -- HsType -> P HsContext
  24         , checkInstType         -- HsType -> P HsType
  25         , checkAssertion        -- HsType -> P HsAsst
  26         , checkDataHeader       -- HsQualType -> P (HsContext,HsName,[HsName])
  27         , checkSimple           -- HsType -> [HsName] -> P ((HsName,[HsName]))
  28         , checkPattern          -- HsExp -> P HsPat
  29         , checkPatterns         -- [HsExp] -> P [HsPat]
  30         -- , checkExpr          -- HsExp -> P HsExp
  31         , checkValDef           -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  32
  33
  34         -- some built-in names (all :: RdrName)
  35         , unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR
  36         , tupleCon_RDR, tupleTyCon_RDR, ubxTupleCon_RDR, ubxTupleTyCon_RDR
  37         , funTyCon_RDR
  38
  39         -- pseudo-keywords, in var and tyvar forms (all :: RdrName)
  40         , forall_var_RDR
  41         , export_var_RDR, label_var_RDR, dynamic_var_RDR, unsafe_var_RDR
  42
  43         , export_tyvar_RDR, label_tyvar_RDR, dynamic_tyvar_RDR
  44         , unsafe_tyvar_RDR
  45
  46         , minus_RDR, pling_RDR, dot_RDR
  47
  48  ) where
  49
  50 #include "HsVersions.h"
  51
  52 import Lex
  53 import HsSyn
  54 import SrcLoc
  55 import RdrHsSyn
  56 import RdrName
  57 import CallConv
  58 import PrelMods         ( pRELUDE_Name, mkUbxTupNameStr, mkTupNameStr )
  59 import OccName          ( dataName, tcName, varName, tvName, setOccNameSpace )
  60 import CmdLineOpts      ( opt_NoImplicitPrelude )
  61 import StringBuffer     ( lexemeToString )
  62 import FastString       ( unpackFS )
  63 import ErrUtils
  64 import UniqFM           ( UniqFM, listToUFM, lookupUFM )
  65 import Outputable
  66
  67 -----------------------------------------------------------------------------
  68 -- Misc utils
  69
  70 parseError :: String -> P a
  71 parseError s =
  72   getSrcLocP `thenP` \ loc ->
  73   failMsgP (hcat [ppr loc, text ": ", text s])
  74
  75 parseErrorOnInput :: P a
  76 parseErrorOnInput buf PState{ loc = loc } = PFailed (srcParseErr buf loc)
  77
  78 srcParseErr :: StringBuffer -> SrcLoc -> Message
  79 srcParseErr s l
  80   = hcat [ppr l, ptext SLIT(": parse error on input "),
  81           char '`', text (lexemeToString s), char '\'']
  82
  83 cbot = panic "CCall:result_ty"
  84
  85 -----------------------------------------------------------------------------
  86 -- Special Ids
  87
  88 checkAs, checkQualified, checkHiding :: FAST_STRING -> P ()
  89
  90 checkAs s        | s == SLIT("as")        = returnP ()
  91                  | otherwise              = parseErrorOnInput
  92 checkQualified s | s == SLIT("qualified") = returnP ()
  93                  | otherwise              = parseErrorOnInput
  94 checkHiding s    | s == SLIT("hiding")    = returnP ()
  95                  | otherwise              = parseErrorOnInput
  96
  97 -----------------------------------------------------------------------------
  98 -- splitForConApp
  99
 100 -- When parsing data declarations, we sometimes inadvertently parse
 101 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
 102 -- This function splits up the type application, adds any pending
 103 -- arguments, and converts the type constructor back into a data constructor.
 104
 105 splitForConApp :: RdrNameHsType -> [RdrNameBangType]
 106         -> P (RdrName, [RdrNameBangType])
 107
 108 splitForConApp  t ts = split t ts
 109  where
 110         split (MonoTyApp t u) ts = split t (Unbanged u : ts)
 111
 112         split (MonoTyVar t)   ts  = returnP (con, ts)
 113            where t_occ = rdrNameOcc t
 114                  con   = setRdrNameOcc t (setOccNameSpace t_occ dataName)
 115
 116         split _ _ = parseError "Illegal data/newtype declaration"
 117
 118 ----------------------------------------------------------------------------
 119 -- Various Syntactic Checks
 120
 121 callConvFM :: UniqFM CallConv
 122 callConvFM = listToUFM $
 123       map (\ (x,y) -> (_PK_ x,y))
 124      [  ("stdcall",  stdCallConv),
 125         ("ccall",    cCallConv)
 126 --      ("pascal",   pascalCallConv),
 127 --      ("fastcall", fastCallConv)
 128      ]
 129
 130 checkCallConv :: FAST_STRING -> P CallConv
 131 checkCallConv s =
 132   case lookupUFM callConvFM s of
 133         Nothing -> parseError ("unknown calling convention: `"
 134                                  ++ unpackFS s ++ "'")
 135         Just conv -> returnP conv
 136
 137 checkInstType :: RdrNameHsType -> P RdrNameHsType
 138 checkInstType t
 139   = case t of
 140         HsForAllTy tvs ctxt ty ->
 141                 checkAssertion ty [] `thenP` \(c,ts)->
 142                 returnP (HsForAllTy tvs ctxt (MonoDictTy c ts))
 143
 144         ty ->   checkAssertion ty [] `thenP` \(c,ts)->
 145                 returnP (HsForAllTy Nothing [] (MonoDictTy c ts))
 146
 147 checkContext :: RdrNameHsType -> P RdrNameContext
 148 checkContext (MonoTupleTy ts True)
 149   = mapP (\t -> checkAssertion t []) ts `thenP` \cs ->
 150     returnP cs
 151 checkContext (MonoTyVar t) -- empty contexts are allowed
 152   | t == unitTyCon_RDR = returnP []
 153 checkContext t
 154   = checkAssertion t [] `thenP` \c ->
 155     returnP [c]
 156
 157 checkAssertion :: RdrNameHsType -> [RdrNameHsType]
 158         -> P (ClassAssertion RdrName)
 159 checkAssertion (MonoTyVar t) args@(_:_) | not (isRdrTyVar t)
 160         = returnP (t,args)
 161 checkAssertion (MonoTyApp l r) args = checkAssertion l (r:args)
 162 checkAssertion _ _ = parseError "Illegal class assertion"
 163
 164 checkDataHeader :: RdrNameHsType
 165         -> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
 166 checkDataHeader (HsForAllTy Nothing cs t) =
 167    checkSimple t []          `thenP` \(c,ts) ->
 168    returnP (cs,c,map UserTyVar ts)
 169 checkDataHeader t =
 170    checkSimple t []          `thenP` \(c,ts) ->
 171    returnP ([],c,map UserTyVar ts)
 172
 173 checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
 174 checkSimple (MonoTyApp l (MonoTyVar a)) xs | isRdrTyVar a
 175    = checkSimple l (a:xs)
 176 checkSimple (MonoTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs)
 177 checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration"
 178
 179 ---------------------------------------------------------------------------
 180 -- Checking Patterns.
 181
 182 -- We parse patterns as expressions and check for valid patterns below,
 183 -- nverting the expression into a pattern at the same time.
 184
 185 checkPattern :: RdrNameHsExpr -> P RdrNamePat
 186 checkPattern e = checkPat e []
 187
 188 checkPatterns :: [RdrNameHsExpr] -> P [RdrNamePat]
 189 checkPatterns es = mapP checkPattern es
 190
 191 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
 192 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
 193 checkPat (HsApp f x) args =
 194         checkPat x [] `thenP` \x ->
 195         checkPat f (x:args)
 196 checkPat e [] = case e of
 197         EWildPat           -> returnP WildPatIn
 198         HsVar x            -> returnP (VarPatIn x)
 199         HsLit l            -> returnP (LitPatIn l)
 200         ELazyPat e         -> checkPat e [] `thenP` (returnP . LazyPatIn)
 201         EAsPat n e         -> checkPat e [] `thenP` (returnP . AsPatIn n)
 202         ExprWithTySig e t  -> checkPat e [] `thenP` \e ->
 203                               -- pattern signatures are parsed as sigtypes,
 204                               -- but they aren't explicit forall points.  Hence
 205                               -- we have to remove the implicit forall here.
 206                               let t' = case t of
 207                                           HsForAllTy Nothing [] ty -> ty
 208                                           other -> other
 209                               in
 210                               returnP (SigPatIn e t')
 211
 212         OpApp (HsVar n) (HsVar plus) _ (HsLit k@(HsInt _)) | plus == plus_RDR
 213                            -> returnP (NPlusKPatIn n k)
 214
 215         OpApp l op fix r   -> checkPat l [] `thenP` \l ->
 216                               checkPat r [] `thenP` \r ->
 217                               case op of
 218                                  HsVar c -> returnP (ConOpPatIn l c fix r)
 219                                  _ -> patFail
 220
 221         NegApp l r         -> checkPat l [] `thenP` (returnP . NegPatIn)
 222         HsPar e            -> checkPat e [] `thenP` (returnP . ParPatIn)
 223         ExplicitList es    -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 224                               returnP (ListPatIn ps)
 225         ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 226                               returnP (TuplePatIn ps b)
 227         RecordCon c fs     -> mapP checkPatField fs `thenP` \fs ->
 228                               returnP (RecPatIn c fs)
 229         _ -> patFail
 230
 231 checkPat _ _ = patFail
 232
 233 checkPatField :: (RdrName, RdrNameHsExpr, Bool)
 234         -> P (RdrName, RdrNamePat, Bool)
 235 checkPatField (n,e,b) =
 236         checkPat e [] `thenP` \p ->
 237         returnP (n,p,b)
 238
 239 patFail = parseError "Parse error in pattern"
 240
 241 ---------------------------------------------------------------------------
 242 -- Check Expression Syntax
 243
 244 {-
 245 We can get away without checkExpr if the renamer generates errors for
 246 pattern syntax used in expressions (wildcards, as patterns and lazy
 247 patterns).
 248
 249 checkExpr :: RdrNameHsExpr -> P RdrNameHsExpr
 250 checkExpr e = case e of
 251         HsVar _                   -> returnP e
 252         HsLit _                   -> returnP e
 253         HsLam match               -> checkMatch match `thenP` (returnP.HsLam)
 254         HsApp e1 e2               -> check2Exprs e1 e2 HsApp
 255         OpApp e1 e2 fix e3        -> checkExpr e1 `thenP` \e1 ->
 256                                      checkExpr e2 `thenP` \e2 ->
 257                                      checkExpr e3 `thenP` \e3 ->
 258                                      returnP (OpApp e1 e2 fix e3)
 259         NegApp e neg              -> checkExpr e `thenP` \e ->
 260                                      returnP (NegApp e neg)
 261         HsPar e                   -> check1Expr e HsPar
 262         SectionL e1 e2            -> check2Exprs e1 e2 SectionL
 263         SectionR e1 e2            -> check2Exprs e1 e2 SectionR
 264         HsCase e alts             -> mapP checkMatch alts `thenP` \alts ->
 265                                      checkExpr e `thenP` \e ->
 266                                      returnP (HsCase e alts)
 267         HsIf e1 e2 e3             -> check3Exprs e1 e2 e3 HsIf
 268
 269         HsLet bs e                -> check1Expr e (HsLet bs)
 270         HsDo stmts                -> mapP checkStmt stmts `thenP` (returnP . HsDo)
 271         HsTuple es                -> checkManyExprs es HsTuple
 272         HsList es                 -> checkManyExprs es HsList
 273         HsRecConstr c fields      -> mapP checkField fields `thenP` \fields ->
 274                                      returnP (HsRecConstr c fields)
 275         HsRecUpdate e fields      -> mapP checkField fields `thenP` \fields ->
 276                                      checkExpr e `thenP` \e ->
 277                                      returnP (HsRecUpdate e fields)
 278         HsEnumFrom e              -> check1Expr e HsEnumFrom
 279         HsEnumFromTo e1 e2        -> check2Exprs e1 e2 HsEnumFromTo
 280         HsEnumFromThen e1 e2      -> check2Exprs e1 e2 HsEnumFromThen
 281         HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo
 282         HsListComp e stmts        -> mapP checkStmt stmts `thenP` \stmts ->
 283                                      checkExpr e `thenP` \e ->
 284                                      returnP (HsListComp e stmts)
 285         RdrNameHsExprTypeSig loc e ty     -> checkExpr e `thenP` \e ->
 286                                      returnP (RdrNameHsExprTypeSig loc e ty)
 287         _                         -> parseError "parse error in expression"
 288
 289 -- type signature for polymorphic recursion!!
 290 check1Expr :: RdrNameHsExpr -> (RdrNameHsExpr -> a) -> P a
 291 check1Expr e f = checkExpr e `thenP` (returnP . f)
 292
 293 check2Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a
 294 check2Exprs e1 e2 f =
 295         checkExpr e1 `thenP` \e1 ->
 296         checkExpr e2 `thenP` \e2 ->
 297         returnP (f e1 e2)
 298
 299 check3Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a
 300 check3Exprs e1 e2 e3 f =
 301         checkExpr e1 `thenP` \e1 ->
 302         checkExpr e2 `thenP` \e2 ->
 303         checkExpr e3 `thenP` \e3 ->
 304         returnP (f e1 e2 e3)
 305
 306 checkManyExprs es f =
 307         mapP checkExpr es `thenP` \es ->
 308         returnP (f es)
 309
 310 checkAlt (HsAlt loc p galts bs)
 311         = checkGAlts galts `thenP` \galts -> returnP (HsAlt loc p galts bs)
 312
 313 checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt
 314 checkGAlts (HsGuardedAlts galts)
 315     = mapP checkGAlt galts `thenP` (returnP . HsGuardedAlts)
 316
 317 checkGAlt (HsGuardedAlt loc e1 e2) = check2Exprs e1 e2 (HsGuardedAlt loc)
 318
 319 checkStmt (HsGenerator p e) = check1Expr e (HsGenerator p)
 320 checkStmt (HsQualifier e)   = check1Expr e HsQualifier
 321 checkStmt s@(HsLetStmt bs)  = returnP s
 322
 323 checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n)
 324 checkField e = returnP e
 325 -}
 326 ---------------------------------------------------------------------------
 327 -- Check Equation Syntax
 328
 329 checkValDef
 330         :: RdrNameHsExpr
 331         -> Maybe RdrNameHsType
 332         -> RdrNameGRHSs
 333         -> SrcLoc
 334         -> P RdrNameMonoBinds
 335
 336 checkValDef lhs opt_sig grhss loc
 337  = case isFunLhs lhs [] of
 338            Just (f,inf,es) ->
 339                 checkPatterns es `thenP` \ps ->
 340                 returnP (FunMonoBind f inf [Match [] ps opt_sig grhss] loc)
 341
 342            Nothing ->
 343                 checkPattern lhs `thenP` \lhs ->
 344                 returnP (PatMonoBind lhs grhss loc)
 345
 346 -- A variable binding is parsed as an RdrNamePatBind.
 347
 348 isFunLhs (OpApp l (HsVar op) fix r) []  | not (isRdrDataCon op)
 349                                 = Just (op, True, [l,r])
 350 isFunLhs (HsVar f) es@(_:_)  | not (isRdrDataCon f)
 351                                 = Just (f,False,es)
 352 isFunLhs (HsApp f e) es         = isFunLhs f (e:es)
 353 isFunLhs (HsPar e)   es         = isFunLhs e es
 354 isFunLhs _ _                    = Nothing
 355
 356 ---------------------------------------------------------------------------
 357 -- Miscellaneous utilities
 358
 359 checkPrec :: Integer -> P ()
 360 checkPrec i | 0 <= i && i <= 9 = returnP ()
 361             | otherwise        = parseError "precedence out of range"
 362
 363 mkRecConstrOrUpdate
 364         :: RdrNameHsExpr
 365         -> RdrNameHsRecordBinds
 366         -> P RdrNameHsExpr
 367
 368 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
 369   = returnP (RecordCon c fs)
 370 mkRecConstrOrUpdate exp fs@(_:_)
 371   = returnP (RecordUpd exp fs)
 372 mkRecConstrOrUpdate _ _
 373   = parseError "Empty record update"
 374
 375 -----------------------------------------------------------------------------
 376 -- group function bindings into equation groups
 377
 378 -- we assume the bindings are coming in reverse order, so we take the srcloc
 379 -- from the *last* binding in the group as the srcloc for the whole group.
 380
 381 groupBindings :: [RdrBinding] -> RdrBinding
 382 groupBindings binds = group Nothing binds
 383   where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
 384         group (Just bind) [] = RdrValBinding bind
 385         group Nothing [] = RdrNullBind
 386         group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
 387                     (RdrValBinding (FunMonoBind f' _ [mtch] loc) : binds)
 388             | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
 389
 390         group (Just so_far) binds
 391             = RdrValBinding so_far `RdrAndBindings` group Nothing binds
 392         group Nothing (bind:binds)
 393             = case bind of
 394                 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
 395                 other -> bind `RdrAndBindings` group Nothing binds
 396
 397 -----------------------------------------------------------------------------
 398 -- Built-in names
 399
 400 unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR :: RdrName
 401 tupleCon_RDR, tupleTyCon_RDR            :: Int -> RdrName
 402 ubxTupleCon_RDR, ubxTupleTyCon_RDR      :: Int -> RdrName
 403
 404 unitCon_RDR
 405         | opt_NoImplicitPrelude = mkSrcUnqual   dataName unitName
 406         | otherwise             = mkPreludeQual dataName pRELUDE_Name unitName
 407
 408 unitTyCon_RDR
 409         | opt_NoImplicitPrelude = mkSrcUnqual   tcName unitName
 410         | otherwise             = mkPreludeQual tcName pRELUDE_Name unitName
 411
 412 nilCon_RDR
 413         | opt_NoImplicitPrelude = mkSrcUnqual   dataName listName
 414         | otherwise             = mkPreludeQual dataName pRELUDE_Name listName
 415
 416 listTyCon_RDR
 417         | opt_NoImplicitPrelude = mkSrcUnqual   tcName listName
 418         | otherwise             = mkPreludeQual tcName pRELUDE_Name listName
 419
 420 funTyCon_RDR
 421         | opt_NoImplicitPrelude = mkSrcUnqual   tcName funName
 422         | otherwise             = mkPreludeQual tcName pRELUDE_Name funName
 423
 424 tupleCon_RDR arity
 425   | opt_NoImplicitPrelude = mkSrcUnqual   dataName (snd (mkTupNameStr arity))
 426   | otherwise             = mkPreludeQual dataName pRELUDE_Name
 427                                 (snd (mkTupNameStr arity))
 428
 429 tupleTyCon_RDR arity
 430   | opt_NoImplicitPrelude = mkSrcUnqual   tcName (snd (mkTupNameStr arity))
 431   | otherwise             = mkPreludeQual tcName pRELUDE_Name
 432                                 (snd (mkTupNameStr arity))
 433
 434
 435 ubxTupleCon_RDR arity
 436   | opt_NoImplicitPrelude = mkSrcUnqual   dataName (snd (mkUbxTupNameStr arity))
 437   | otherwise             = mkPreludeQual dataName pRELUDE_Name
 438                                 (snd (mkUbxTupNameStr arity))
 439
 440 ubxTupleTyCon_RDR arity
 441   | opt_NoImplicitPrelude = mkSrcUnqual   tcName (snd (mkUbxTupNameStr arity))
 442   | otherwise             = mkPreludeQual tcName pRELUDE_Name
 443                                 (snd (mkUbxTupNameStr arity))
 444
 445 unitName = SLIT("()")
 446 funName  = SLIT("(->)")
 447 listName = SLIT("[]")
 448
 449 forallName          = SLIT("forall")
 450 exportName          = SLIT("export")
 451 labelName           = SLIT("label")
 452 dynamicName         = SLIT("dynamic")
 453 unsafeName          = SLIT("unsafe")
 454
 455 forall_var_RDR      = mkSrcUnqual varName forallName
 456 export_var_RDR      = mkSrcUnqual varName exportName
 457 label_var_RDR       = mkSrcUnqual varName labelName
 458 dynamic_var_RDR     = mkSrcUnqual varName dynamicName
 459 unsafe_var_RDR      = mkSrcUnqual varName unsafeName
 460
 461 export_tyvar_RDR    = mkSrcUnqual tvName exportName
 462 label_tyvar_RDR     = mkSrcUnqual tvName labelName
 463 dynamic_tyvar_RDR   = mkSrcUnqual tvName dynamicName
 464 unsafe_tyvar_RDR    = mkSrcUnqual tvName unsafeName
 465
 466 minus_RDR           = mkSrcUnqual varName SLIT("-")
 467 pling_RDR           = mkSrcUnqual varName SLIT("!")
 468 dot_RDR             = mkSrcUnqual varName SLIT(".")
 469
 470 plus_RDR            = mkSrcUnqual varName SLIT("+")
 471 \end{code}