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