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         , cbot                  -- a
  10         , mkVanillaCon, mkRecCon,
  11
  12         , mkRecConstrOrUpdate   -- HsExp -> [HsFieldUpdate] -> P HsExp
  13         , groupBindings
  14
  15         , mkExtName             -- Maybe ExtName -> RdrName -> ExtName
  16
  17         , checkPrec             -- String -> P String
  18         , checkContext          -- HsType -> P HsContext
  19         , checkInstType         -- HsType -> P HsType
  20         , checkDataHeader       -- HsQualType -> P (HsContext,HsName,[HsName])
  21         , checkSimple           -- HsType -> [HsName] -> P ((HsName,[HsName]))
  22         , checkPattern          -- HsExp -> P HsPat
  23         , checkPatterns         -- [HsExp] -> P [HsPat]
  24         -- , checkExpr          -- HsExp -> P HsExp
  25         , checkValDef           -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  26         , checkValSig           -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  27  ) where
  28
  29 #include "HsVersions.h"
  30
  31 import Lex
  32 import HsSyn            -- Lots of it
  33 import SrcLoc
  34 import RdrHsSyn         ( mkNPlusKPatIn, unitTyCon_RDR,
  35                           RdrBinding(..),
  36                           RdrNameHsType, RdrNameBangType, RdrNameContext,
  37                           RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs,
  38                           RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails
  39                         )
  40 import RdrName
  41 import CallConv
  42 import OccName          ( dataName, varName, tcClsName,
  43                           occNameSpace, setOccNameSpace, occNameUserString )
  44 import FastString       ( unpackFS )
  45 import UniqFM           ( UniqFM, listToUFM, lookupUFM )
  46 import Outputable
  47
  48 -----------------------------------------------------------------------------
  49 -- Misc utils
  50
  51 parseError :: String -> P a
  52 parseError s =
  53   getSrcLocP `thenP` \ loc ->
  54   failMsgP (hcat [ppr loc, text ": ", text s])
  55
  56 cbot = panic "CCall:result_ty"
  57
  58 -----------------------------------------------------------------------------
  59 -- mkVanillaCon
  60
  61 -- When parsing data declarations, we sometimes inadvertently parse
  62 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
  63 -- This function splits up the type application, adds any pending
  64 -- arguments, and converts the type constructor back into a data constructor.
  65
  66 mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
  67
  68 mkVanillaCon ty tys
  69  = split ty tys
  70  where
  71    split (HsAppTy t u)  ts = split t (Unbanged u : ts)
  72    split (HsTyVar tc)   ts = tyConToDataCon tc  `thenP` \ data_con ->
  73                              returnP (data_con, VanillaCon ts)
  74    split _               _ = parseError "Illegal data/newtype declaration"
  75
  76 mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
  77 mkRecCon con fields
  78   = tyConToDataCon con  `thenP` \ data_con ->
  79     returnP (data_con, RecCon fields)
  80
  81 tyConToDataCon :: RdrName -> P RdrName
  82 tyConToDataCon tc
  83   | occNameSpace tc_occ == tcClsName
  84   = returnP (setRdrNameOcc tc (setOccNameSpace tc_occ dataName))
  85   | otherwise
  86   = parseError (showSDoc (text "not a constructor:" <+> quotes (ppr tc)))
  87   where
  88     tc_occ   = rdrNameOcc tc
  89
  90
  91 ----------------------------------------------------------------------------
  92 -- Various Syntactic Checks
  93
  94 callConvFM :: UniqFM CallConv
  95 callConvFM = listToUFM $
  96       map (\ (x,y) -> (_PK_ x,y))
  97      [  ("stdcall",  stdCallConv),
  98         ("ccall",    cCallConv)
  99 --      ("pascal",   pascalCallConv),
 100 --      ("fastcall", fastCallConv)
 101      ]
 102
 103 checkCallConv :: FAST_STRING -> P CallConv
 104 checkCallConv s =
 105   case lookupUFM callConvFM s of
 106         Nothing -> parseError ("unknown calling convention: `"
 107                                  ++ unpackFS s ++ "'")
 108         Just conv -> returnP conv
 109
 110 checkInstType :: RdrNameHsType -> P RdrNameHsType
 111 checkInstType t
 112   = case t of
 113         HsForAllTy tvs ctxt ty ->
 114                 checkDictTy ty [] `thenP` \ dict_ty ->
 115                 returnP (HsForAllTy tvs ctxt dict_ty)
 116
 117         ty ->   checkDictTy ty [] `thenP` \ dict_ty->
 118                 returnP (HsForAllTy Nothing [] dict_ty)
 119
 120 checkContext :: RdrNameHsType -> P RdrNameContext
 121 checkContext (HsTupleTy _ ts)
 122   = mapP (\t -> checkPred t []) ts `thenP` \ps ->
 123     returnP ps
 124 checkContext (HsTyVar t) -- empty contexts are allowed
 125   | t == unitTyCon_RDR = returnP []
 126 checkContext t
 127   = checkPred t [] `thenP` \p ->
 128     returnP [p]
 129
 130 checkPred :: RdrNameHsType -> [RdrNameHsType]
 131         -> P (HsPred RdrName)
 132 checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
 133         = returnP (HsPClass t args)
 134 checkPred (HsAppTy l r) args = checkPred l (r:args)
 135 checkPred (HsPredTy (HsPIParam n ty)) [] = returnP (HsPIParam n ty)
 136 checkPred _ _ = parseError "Illegal class assertion"
 137
 138 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
 139 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
 140         = returnP (mkHsDictTy t args)
 141 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
 142 checkDictTy _ _ = parseError "Illegal class assertion"
 143
 144 -- Put more comments!
 145 -- Checks that the lhs of a datatype declaration
 146 -- is of the form Context => T a b ... z
 147 checkDataHeader :: RdrNameHsType
 148         -> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
 149
 150 checkDataHeader (HsForAllTy Nothing cs t) =
 151    checkSimple t []          `thenP` \(c,ts) ->
 152    returnP (cs,c,map UserTyVar ts)
 153 checkDataHeader t =
 154    checkSimple t []          `thenP` \(c,ts) ->
 155    returnP ([],c,map UserTyVar ts)
 156
 157 -- Checks the type part of the lhs of a datatype declaration
 158 checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
 159 checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a
 160    = checkSimple l (a:xs)
 161 checkSimple (HsTyVar tycon) xs | not (isRdrTyVar tycon) = returnP (tycon,xs)
 162
 163 checkSimple (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) []
 164   | not (isRdrTyVar tycon) && isRdrTyVar t1 && isRdrTyVar t2
 165   = returnP (tycon,[t1,t2])
 166
 167 checkSimple t _ = parseError "Illegal left hand side in data/newtype declaration"
 168
 169 ---------------------------------------------------------------------------
 170 -- Checking Patterns.
 171
 172 -- We parse patterns as expressions and check for valid patterns below,
 173 -- converting the expression into a pattern at the same time.
 174
 175 checkPattern :: RdrNameHsExpr -> P RdrNamePat
 176 checkPattern e = checkPat e []
 177
 178 checkPatterns :: [RdrNameHsExpr] -> P [RdrNamePat]
 179 checkPatterns es = mapP checkPattern es
 180
 181 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
 182 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
 183 checkPat (HsApp f x) args =
 184         checkPat x [] `thenP` \x ->
 185         checkPat f (x:args)
 186 checkPat e [] = case e of
 187         EWildPat           -> returnP WildPatIn
 188         HsVar x            -> returnP (VarPatIn x)
 189         HsLit l            -> returnP (LitPatIn l)
 190         HsOverLit l        -> returnP (NPatIn l)
 191         ELazyPat e         -> checkPat e [] `thenP` (returnP . LazyPatIn)
 192         EAsPat n e         -> checkPat e [] `thenP` (returnP . AsPatIn n)
 193         ExprWithTySig e t  -> checkPat e [] `thenP` \e ->
 194                               -- Pattern signatures are parsed as sigtypes,
 195                               -- but they aren't explicit forall points.  Hence
 196                               -- we have to remove the implicit forall here.
 197                               let t' = case t of
 198                                           HsForAllTy Nothing [] ty -> ty
 199                                           other -> other
 200                               in
 201                               returnP (SigPatIn e t')
 202
 203         OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k _))
 204                            | plus == plus_RDR
 205                            -> returnP (mkNPlusKPatIn n lit)
 206
 207         OpApp l op fix r   -> checkPat l [] `thenP` \l ->
 208                               checkPat r [] `thenP` \r ->
 209                               case op of
 210                                  HsVar c -> returnP (ConOpPatIn l c fix r)
 211                                  _ -> patFail
 212
 213         HsPar e            -> checkPat e [] `thenP` (returnP . ParPatIn)
 214         ExplicitList es    -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 215                               returnP (ListPatIn ps)
 216
 217         ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
 218                               returnP (TuplePatIn ps b)
 219
 220         RecordCon c fs     -> mapP checkPatField fs `thenP` \fs ->
 221                               returnP (RecPatIn c fs)
 222 -- Generics
 223         HsType ty          -> returnP (TypePatIn ty)
 224         _ -> patFail
 225
 226 checkPat _ _ = patFail
 227
 228 checkPatField :: (RdrName, RdrNameHsExpr, Bool)
 229         -> P (RdrName, RdrNamePat, Bool)
 230 checkPatField (n,e,b) =
 231         checkPat e [] `thenP` \p ->
 232         returnP (n,p,b)
 233
 234 patFail = parseError "Parse error in pattern"
 235
 236
 237 ---------------------------------------------------------------------------
 238 -- Check Equation Syntax
 239
 240 checkValDef
 241         :: RdrNameHsExpr
 242         -> Maybe RdrNameHsType
 243         -> RdrNameGRHSs
 244         -> SrcLoc
 245         -> P RdrBinding
 246
 247 checkValDef lhs opt_sig grhss loc
 248  = case isFunLhs lhs [] of
 249            Just (f,inf,es) ->
 250                 checkPatterns es `thenP` \ps ->
 251                 returnP (RdrValBinding (FunMonoBind f inf [Match [] ps opt_sig grhss] loc))
 252
 253            Nothing ->
 254                 checkPattern lhs `thenP` \lhs ->
 255                 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
 256
 257 checkValSig
 258         :: RdrNameHsExpr
 259         -> RdrNameHsType
 260         -> SrcLoc
 261         -> P RdrBinding
 262 checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc))
 263 checkValSig other     ty loc = parseError "Type signature given for an expression"
 264
 265
 266 -- A variable binding is parsed as an RdrNameFunMonoBind.
 267 -- See comments with HsBinds.MonoBinds
 268
 269 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
 270 isFunLhs (OpApp l (HsVar op) fix r) es  | not (isRdrDataCon op)
 271                                 = Just (op, True, (l:r:es))
 272 isFunLhs (HsVar f) es | not (isRdrDataCon f)
 273                                 = Just (f,False,es)
 274 isFunLhs (HsApp f e) es         = isFunLhs f (e:es)
 275 isFunLhs (HsPar e)   es         = isFunLhs e es
 276 isFunLhs _ _                    = Nothing
 277
 278 ---------------------------------------------------------------------------
 279 -- Miscellaneous utilities
 280
 281 checkPrec :: Integer -> P ()
 282 checkPrec i | 0 <= i && i <= 9 = returnP ()
 283             | otherwise        = parseError "precedence out of range"
 284
 285 mkRecConstrOrUpdate
 286         :: RdrNameHsExpr
 287         -> RdrNameHsRecordBinds
 288         -> P RdrNameHsExpr
 289
 290 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
 291   = returnP (RecordCon c fs)
 292 mkRecConstrOrUpdate exp fs@(_:_)
 293   = returnP (RecordUpd exp fs)
 294 mkRecConstrOrUpdate _ _
 295   = parseError "Empty record update"
 296
 297 -- Supplying the ext_name in a foreign decl is optional ; if it
 298 -- isn't there, the Haskell name is assumed. Note that no transformation
 299 -- of the Haskell name is then performed, so if you foreign export (++),
 300 -- it's external name will be "++". Too bad; it's important because we don't
 301 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 302 -- (This is why we use occNameUserString.)
 303
 304 mkExtName :: Maybe ExtName -> RdrName -> ExtName
 305 mkExtName Nothing rdrNm = ExtName (_PK_ (occNameUserString (rdrNameOcc rdrNm)))
 306                                   Nothing
 307 mkExtName (Just x) _    = x
 308
 309 -----------------------------------------------------------------------------
 310 -- group function bindings into equation groups
 311
 312 -- we assume the bindings are coming in reverse order, so we take the srcloc
 313 -- from the *last* binding in the group as the srcloc for the whole group.
 314
 315 groupBindings :: [RdrBinding] -> RdrBinding
 316 groupBindings binds = group Nothing binds
 317   where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
 318         group (Just bind) [] = RdrValBinding bind
 319         group Nothing [] = RdrNullBind
 320
 321                 -- don't group together FunMonoBinds if they have
 322                 -- no arguments.  This is necessary now that variable bindings
 323                 -- with no arguments are now treated as FunMonoBinds rather
 324                 -- than pattern bindings (tests/rename/should_fail/rnfail002).
 325         group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
 326                     (RdrValBinding (FunMonoBind f' _
 327                                         [mtch@(Match _ (_:_) _ _)] loc)
 328                         : binds)
 329             | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
 330
 331         group (Just so_far) binds
 332             = RdrValBinding so_far `RdrAndBindings` group Nothing binds
 333         group Nothing (bind:binds)
 334             = case bind of
 335                 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
 336                 other -> bind `RdrAndBindings` group Nothing binds
 337
 338 plus_RDR = mkSrcUnqual varName SLIT("+")
 339 \end{code}